paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-08 16:38:17 +02:00
Code Issues Packages Projects Releases Wiki Activity

TAChart: Refactor BarHeight property of TStateSeries. Integrate code into TAMultiSeries, delete TAStateSeries.

Browse Source
This commit is contained in:
wp_xyz 2025-02-28 19:55:27 +01:00
parent 45eabe826d
commit f97f7e3946
6 changed files with 666 additions and 679 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
components/tachart/demo/stateseries/main.lfm
View File

@ -43,15 +43,15 @@ object MainForm: TMainForm
BorderSpacing.Around = 6
object MachineA_Series: TStateSeries
Title = 'Machine A'
Brush.Color = clRed
BarBrush.Color = clRed
end
object MachineB_Series: TStateSeries
Title = 'Machine B'
Brush.Color = clRed
BarBrush.Color = clRed
end
object MachineC_Series: TStateSeries
Title = 'Machine C'
Brush.Color = clRed
BarBrush.Color = clRed
end
end
object FlowPanel1: TFlowPanel
@ -76,13 +76,18 @@ object MainForm: TMainForm
end
item
Control = cbRotated
WrapAfter = waForce
WrapAfter = waAuto
Index = 2
end
item
Control = cbAdjustMargin
WrapAfter = waForce
Index = 3
end
item
Control = Panel1
WrapAfter = waAuto
Index = 3
Index = 4
end>
FlowLayout = tlTop
FlowStyle = fsLeftRightTopBottom
@ -124,6 +129,16 @@ object MainForm: TMainForm
TabOrder = 2
OnChange = cbRotatedChange
end
object cbAdjustMargin: TCheckBox
Left = 335
Height = 19
Top = 0
Width = 93
Anchors = []
Caption = 'Adjust margin'
TabOrder = 4
OnChange = cbAdjustMarginChange
end
object Panel1: TPanel
Left = 0
Height = 25

282
components/tachart/demo/stateseries/main.pas
View File

@ -5,10 +5,10 @@ unit Main;
interface
uses
ComCtrls, SysUtils, Classes,
ComCtrls, SysUtils, Classes, Math,
Graphics, Forms, Controls, StdCtrls, ExtCtrls, Dialogs, LCLVersion,
TAGraph, TAIntervalSources, TACustomSeries, TASeries, TASources, TAChartUtils,
TATextElements, TATools, TAStateSeries, TAChartAxisUtils;
TAGraph, TAIntervalSources, TASources, TAChartUtils, TATextElements, TATools,
TAChartAxisUtils, TACustomSeries, TASeries, TAMultiSeries;
type
@ -17,6 +17,7 @@ type
TMainForm = class(TForm)
Bevel1: TBevel;
Chart: TChart;
cbAdjustMargin: TCheckBox;
FlowPanel1: TFlowPanel;
Label1: TLabel;
MachineA_Series: TStateSeries;
@ -37,6 +38,7 @@ type
procedure cbRotatedChange(Sender: TObject);
procedure cbSeriesMarksChange(Sender: TObject);
procedure cbShowPopupHintsChange(Sender: TObject);
procedure cbAdjustMarginChange(Sender: TObject);
procedure Chart1AxisList1GetMarkText(Sender: TObject; var AText: String;
AMark: Double);
procedure FormCreate(Sender: TObject);
@ -62,17 +64,99 @@ implementation
const
clRepair = $4040FF; // red
clProduction = $00C800; // green
clDevelopment = $FF8080; // blue
clDevelopment = $FC8B70; // blue
clMaintainance = clYellow; // yellow
idxMachineA = 0;
idxMachineB = 1;
idxMachineC = 2;
procedure TMainForm.cbAdjustMarginChange(Sender: TObject);
var
ext: TDoubleRect;
begin
if cbAdjustMargin.Checked then
begin
ext := Chart.LogicalExtent;
if MachineA_Series.IsRotated then
begin
Chart.Extent.XMin := Floor(ext.a.x) + 0.5;
Chart.Extent.XMax := Ceil(ext.b.x) - 0.5;
Chart.Extent.UseXMin := true;
Chart.Extent.UseXMax := true;
end else
begin
Chart.Extent.YMin := Floor(ext.a.y) + 0.5;
Chart.Extent.YMax := Ceil(ext.b.y) - 0.5;
Chart.Extent.UseYMin := true;
Chart.Extent.UseYMax := true;
end;
end else
begin
Chart.Extent.UseXMin := false;
Chart.Extent.UseXMax := false;
Chart.Extent.UseYMin := false;
Chart.Extent.UseYMax := false;
end;
end;
// Toggles between "normal" and "rotated" state series (horizontal or
// vertical orientation)
procedure TMainForm.cbRotatedChange(Sender: TObject);
var
w, h, i: Integer;
begin
w := Width;
h := Height;
SetBounds(Left, Top, h, w);
for i := 0 to Chart.SeriesCount-1 do
if Chart.Series[i] is TStateSeries then
with TStateSeries(Chart.Series[i]) do
if cbRotated.Checked then
begin
AxisIndexX := 0;
AxisIndexY := 1;
end else
begin
AxisIndexX := 1;
AxisIndexY := 0;
end;
if cbRotated.Checked then
SetupRotatedAxes
else
SetupNormalAxes;
end;
// Shows/hides series marks
procedure TMainForm.cbSeriesMarksChange(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Chart.SeriesCount-1 do
if Chart.Series[i] is TStateSeries then
with TStateSeries(Chart.Series[i]) do
if cbSeriesMarks.Checked then
Marks.Style := smsLabel
else
Marks.Style := smsNone;
end;
// Shows/hides mouse-over popup hints
procedure TMainForm.cbShowPopupHintsChange(Sender: TObject);
begin
DatapointHintTool.Enabled := cbShowPopupHints.Checked;
end;
// Displays the last time tick on the x axis as '24:00' rather than '0:00'
procedure TMainForm.Chart1AxisList1GetMarkText(Sender: TObject; var AText: String;
AMark: Double);
begin
if AMark = 1.0 then AText := '24:00';
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
FormatSettings.Decimalseparator := '.';
// Provide y axis labels
MachineLabelsChartSource.Add(idxMachineA, idxMachineA, 'Machine'+LineEnding+'A');
MachineLabelsChartSource.Add(idxMachineB, idxMachineB, 'Machine'+LineEnding+'B');
@ -103,67 +187,39 @@ begin
PrepareMarks(MachineC_Series);
end;
procedure TMainForm.TrackBar1Change(Sender: TObject);
begin
MachineA_Series.BarHeightPercent := Trackbar1.Position;
MachineB_Series.BarHeightPercent := Trackbar1.Position;
MachineC_Series.BarHeightPercent := Trackbar1.Position;
end;
// Show/hide series marks
procedure TMainForm.cbSeriesMarksChange(Sender: TObject);
// Composes the label text from the label value and each data point's
// state duration.
procedure TMainForm.GetMarkTextHandler(ASeries: TChartSeries;
APointIndex, AXIndex, AYIndex: Integer; var AFormattedMark: String);
var
i: Integer;
txt: String;
t1, t2: TDateTime;
begin
for i := 0 to Chart.SeriesCount-1 do
if Chart.Series[i] is TStateSeries then
with TStateSeries(Chart.Series[i]) do
if cbSeriesMarks.Checked then
Marks.Style := smsLabel
else
Marks.Style := smsNone;
with ASeries.Source[APointIndex]^ do
begin
txt := Text;
t1 := GetX(0);
t2 := GetX(1);
end;
AFormattedMark := Format('%s'+LineEnding+'%s', [txt, FormatDateTime('[hh]:nn', t2-t1, [fdoInterval])]);
end;
procedure TMainForm.SetupRotatedAxes;
// Prepares the marks for the series and for the popup hints:
// no border, no background, centered, user-defined text (see GetMarkTextHandler)
procedure TMainForm.PrepareMarks(ASeries: TStateSeries);
begin
// Bottom axis marks
Chart.BottomAxis.Marks.Source := MachineLabelsChartSource;
Chart.BottomAxis.Marks.Style := smsLabel;
Chart.BottomAxis.OnGetMarkText := nil;
Chart.BottomAxis.TickLength := 0;
// Left axis marks
Chart.LeftAxis.Marks.Source := DateTimeIntervalChartSource;
Chart.LeftAxis.Marks.Style := smsLabel;
Chart.LeftAxis.OnGetMarkText := @Chart1AxisList1GetMarkText;
Chart.LeftAxis.TickLength := 4;
// Nicer grid for the x axis
Chart.BottomAxis.Grid.Visible := false;
Chart.LeftAxis.Grid.Visible := true;
if Chart.BottomAxis.Minors.Count = 0 then
with Chart.BottomAxis.Minors.Add do
begin
Intervals.Count := 1;
Grid.Color := clSilver;
Grid.Style := psSolid;
end;
Chart.BottomAxis.Minors[0].Visible := true;
if Chart.LeftAxis.Minors.Count > 0 then
Chart.LeftAxis.Minors[0].Visible := false;
// Show a full day on the y axis
Chart.LeftAxis.Range.Max := 1.0;
Chart.LeftAxis.Range.Min := 0.0;
Chart.LeftAxis.Range.UseMax := true;
Chart.LeftAxis.Range.UseMin := true;
Chart.BottomAxis.Range.UseMin := false;
Chart.BottomAxis.Range.UseMax := false;
// Restore left axis direction
Chart.LeftAxis.Inverted := false;
ASeries.Marks.Style := smsLabel;
ASeries.Marks.Frame.Visible := false;
ASeries.Marks.LabelBrush.Style := bsClear;
ASeries.Marks.LinkPen.Visible := false;
ASeries.Marks.Distance := 0;
ASeries.Marks.Alignment := taCenter;
ASeries.Marks.Attachment := maCenter;
ASeries.MarkPositions := lmpInside;
ASeries.OnGetMarkText := @GetMarkTextHandler;
end;
// Sets axis properties for "normal" (horizontally oriented) state series
procedure TMainForm.SetupNormalAxes;
begin
// Left axis marks
@ -205,75 +261,53 @@ begin
Chart.BottomAxis.Inverted := false;
end;
procedure TMainForm.cbRotatedChange(Sender: TObject);
var
w, h, i: Integer;
// Sets axis properties for the case of "rotated" (vertically oriented) state series
procedure TMainForm.SetupRotatedAxes;
begin
w := Width;
h := Height;
SetBounds(Left, Top, h, w);
for i := 0 to Chart.SeriesCount-1 do
if Chart.Series[i] is TStateSeries then
with TStateSeries(Chart.Series[i]) do
if cbRotated.Checked then
begin
AxisIndexX := 0;
AxisIndexY := 1;
end else
begin
AxisIndexX := 1;
AxisIndexY := 0;
end;
// Bottom axis marks
Chart.BottomAxis.Marks.Source := MachineLabelsChartSource;
Chart.BottomAxis.Marks.Style := smsLabel;
Chart.BottomAxis.OnGetMarkText := nil;
Chart.BottomAxis.TickLength := 0;
if cbRotated.Checked then
SetupRotatedAxes
else
SetupNormalAxes;
// Left axis marks
Chart.LeftAxis.Marks.Source := DateTimeIntervalChartSource;
Chart.LeftAxis.Marks.Style := smsLabel;
Chart.LeftAxis.OnGetMarkText := @Chart1AxisList1GetMarkText;
Chart.LeftAxis.TickLength := 4;
// Nicer grid for the x axis
Chart.BottomAxis.Grid.Visible := false;
Chart.LeftAxis.Grid.Visible := true;
if Chart.BottomAxis.Minors.Count = 0 then
with Chart.BottomAxis.Minors.Add do
begin
Intervals.Count := 1;
Grid.Color := clSilver;
Grid.Style := psSolid;
end;
Chart.BottomAxis.Minors[0].Visible := true;
if Chart.LeftAxis.Minors.Count > 0 then
Chart.LeftAxis.Minors[0].Visible := false;
// Show a full day on the y axis
Chart.LeftAxis.Range.Max := 1.0;
Chart.LeftAxis.Range.Min := 0.0;
Chart.LeftAxis.Range.UseMax := true;
Chart.LeftAxis.Range.UseMin := true;
Chart.BottomAxis.Range.UseMin := false;
Chart.BottomAxis.Range.UseMax := false;
// Restore left axis direction
Chart.LeftAxis.Inverted := false;
end;
// Show/hide mouse-over popup hints
procedure TMainForm.cbShowPopupHintsChange(Sender: TObject);
// A change in the trackbar position should be applied as new series BarHeight value.
procedure TMainForm.TrackBar1Change(Sender: TObject);
begin
DatapointHintTool.Enabled := cbShowPopupHints.Checked;
end;
// Display the last time tick on the x axis as '24:00' rather than '0:00'
procedure TMainForm.Chart1AxisList1GetMarkText(Sender: TObject; var AText: String;
AMark: Double);
begin
if AMark = 1.0 then AText := '24:00';
end;
// Compose the label text from the Label value and the duration of each
// data point.
procedure TMainForm.GetMarkTextHandler(ASeries: TChartSeries;
APointIndex, AXIndex, AYIndex: Integer; var AFormattedMark: String);
var
txt: String;
t1, t2: TDateTime;
begin
with ASeries.Source[APointIndex]^ do
begin
txt := Text;
t1 := GetX(0);
t2 := GetX(1);
end;
AFormattedMark := Format('%s'+LineEnding+'%s', [txt, FormatDateTime('[hh]:nn', t2-t1, [fdoInterval])]);
end;
// Prepare the marks for the series and for the popup hints:
// no border, no background, centered, user-defined text (see GetMarkTextHandler)
procedure TMainForm.PrepareMarks(ASeries: TStateSeries);
begin
ASeries.Marks.Style := smsLabel;
ASeries.Marks.Frame.Visible := false;
ASeries.Marks.LabelBrush.Style := bsClear;
ASeries.Marks.LinkPen.Visible := false;
ASeries.Marks.Distance := 0;
ASeries.Marks.Alignment := taCenter;
ASeries.Marks.Attachment := maCenter;
ASeries.MarkPositions := lmpInside;
ASeries.OnGetMarkText := @GetMarkTextHandler;
MachineA_Series.BarHeight := Trackbar1.Position * 0.01;
MachineB_Series.BarHeight := Trackbar1.Position * 0.01;
MachineC_Series.BarHeight := Trackbar1.Position * 0.01;
end;
end.

6
components/tachart/tachartlazaruspkg.lpk
View File

@ -33,7 +33,7 @@
for details about the copyright.
"/>
<Version Major="1"/>
<Files Count="57">
<Files Count="56">
<Item1>
<Filename Value="tagraph.pas"/>
<HasRegisterProc Value="True"/>
@ -278,10 +278,6 @@
<Filename Value="tacolormap.pas"/>
<UnitName Value="TAColorMap"/>
</Item56>
<Item57>
<Filename Value="tastateseries.pas"/>
<UnitName Value="TAStateSeries"/>
</Item57>
</Files>
<CompatibilityMode Value="True"/>
<LazDoc Paths="$(LazarusDir)\components\tachart\fpdoc"/>

2
components/tachart/tachartlazaruspkg.pas
View File

@ -19,7 +19,7 @@ uses
TACustomFuncSeries, TAFitUtils, TAGUIConnector, TADiagram, TADiagramDrawing,
TADiagramLayout, TAChartStrConsts, TAChartCombos, TAHtml, TAFonts,
TAExpressionSeries, TAFitLib, TASourcePropEditors, TADataPointsEditor,
TAPolygonSeries, TAColorMap, TAStateSeries, LazarusPackageIntf;
TAPolygonSeries, TAColorMap, LazarusPackageIntf;
implementation

487
components/tachart/tamultiseries.pas
View File

@ -1,10 +1,15 @@
{
***************************************************************************
TAMultiSeries.pas
-----------------
Component Library Multi-valued Graph Series
*****************************************************************************
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
Authors: Alexander Klenin
Authors: Alexander Klenin, Werner Pamler
}
@ -350,6 +355,59 @@ type
property VectorCoordKind: TVectorCoordKind read FCoordKind write SetCoordKind default vckCenterDir;
end;
EStateSeriesError = class(EChartError);
TStateSeries = class(TBasicPointSeries)
private
const
DEFAULT_BAR_HEIGHT = 0.7;
private
FBarBrush: TBrush;
FBarHeight: Double;
FBarPen: TPen;
function IsStoredBarHeight: Boolean;
procedure SetBarBrush(AValue: TBrush);
procedure SetBarHeight(AValue: Double);
procedure SetBarPen(AValue: TPen);
protected
FMinYRange: Double;
function CalcBarHeight: Double;
function GetLabelDataPoint(AIndex, AYIndex: Integer): TDoublePoint; override;
procedure GetLegendItems(AItems: TChartLegendItems); override;
function GetYRange: Double;
function NearestYNumber(var AIndex: Integer; ADir: Integer): Double;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Assign(ASource: TPersistent); override;
function AddXY(AStart, AEnd, Y: Double; ALabel: String;
AColor: TColor = clTAColor): Integer;
procedure Draw(ADrawer: IChartDrawer); override;
function Extent: TDoubleRect; override;
function GetImgBarHeight({%H-}AIndex: Integer): Integer;
function GetNearestPoint(const AParams: TNearestPointParams;
out AResults: TNearestPointResults): Boolean; override;
procedure MovePointEx(var AIndex: Integer; AXIndex, AYIndex: Integer;
const ANewPos: TDoublePoint); override;
class procedure GetXYCountNeeded(out AXCount, AYCount: Cardinal); override;
published
property AxisIndexX;
property AxisIndexY;
property BarBrush: TBrush read FBarBrush write SetBarBrush;
property BarHeight: Double read FBarHeight write SetBarHeight stored IsStoredBarHeight;
property BarPen: TPen read FBarPen write SetBarPen;
property MarkPositions;
property Marks;
property Source;
property ToolTargets default [nptPoint, nptXList, nptCustom];
end;
implementation
uses
@ -2574,10 +2632,437 @@ begin
end;
{ TStateSeries }
constructor TStateSeries.Create(AOwner: TComponent);
begin
inherited;
FBarPen := TPen.Create;
FBarPen.Color := clBlack;
FBarPen.OnChange := @StyleChanged;
FBarBrush := TBrush.Create;
FBarBrush.Color := clRed;
FBarBrush.OnChange := @StyleChanged;
FBarHeight := 0.0;
ToolTargets := [nptPoint, nptXList, nptCustom];
end;
destructor TStateSeries.Destroy;
begin
FBarBrush.Free;
FBarPen.Free;
inherited;
end;
function TStateSeries.AddXY(AStart, AEnd, Y: Double;
ALabel: String; AColor: TColor = clTAColor): Integer;
begin
EnsureOrder(AStart, AEnd);
Result := ListSource.AddXListY([AStart, AEnd], Y, ALabel, AColor);
end;
procedure TStateSeries.Assign(ASource: TPersistent);
begin
if ASource is TStateSeries then
with TStateSeries(ASource) do begin
Self.BarBrush.Assign(FBarBrush);
Self.BarHeight := FBarHeight;
Self.BarPen.Assign(FBarPen);
end;
inherited Assign(ASource);
end;
function TStateSeries.CalcBarHeight: Double;
var
yrng: Double;
begin
if FBarHeight > 0 then
Result := FBarHeight
else
begin
Result := DEFAULT_BAR_HEIGHT;
if Count > 1 then
begin
yrng := GetYRange;
if yrng > 0 then
Result := yrng / (Count - 1);
end;
end;
Result := Result * 0.5;
end;
procedure TStateSeries.Draw(ADrawer: IChartDrawer);
var
pointIndex: Integer;
scaledDepth: Integer;
procedure DrawBar(const ARect: TRect);
var
sz: TSize;
c: TColor;
// ic: IChartTCanvasDrawer; -- maybe later...
begin
ADrawer.Pen := FBarPen;
if FBarPen.Color = clDefault then
ADrawer.SetPenColor(FChart.GetDefaultColor(dctFont))
else
ADrawer.SetPenColor(FBarPen.Color);
ADrawer.Brush := FBarBrush;
if FBarBrush.Color = clDefault then
ADrawer.SetBrushColor(FChart.GetDefaultColor(dctBrush))
else
ADrawer.SetPenColor(FBarPen.Color);
c := Source[pointIndex]^.Color;
if c <> clTAColor then
ADrawer.BrushColor := c;
sz := Size(ARect);
if (sz.cx <= 2*FBarPen.Width) or (sz.cy <= 2*FBarPen.Width) then begin
// Bars are too small to distinguish the border from the interior.
ADrawer.SetPenParams(psSolid, ADrawer.BrushColor);
end;
(* todo --- add me
if Assigned(FOnCustomDrawBar) then begin
FOnCustomDrawBar(Self, ADrawer, AR, pointIndex, stackIndex);
exit;
end;
if Supports(ADrawer, IChartTCanvasDrawer, ic) and Assigned(OnBeforeDrawBar) then
OnBeforeDrawBar(Self, ic.Canvas, AR, pointIndex, stackIndex, defaultDrawing);
if not defaultDrawing then exit; *)
ADrawer.Rectangle(ARect);
if scaledDepth > 0 then begin
c := ADrawer.BrushColor;
ADrawer.BrushColor := GetDepthColor(c, true);
ADrawer.DrawLineDepth(
ARect.Left, ARect.Top, ARect.Right - 1, ARect.Top, scaledDepth);
ADrawer.BrushColor := GetDepthColor(c, false);
ADrawer.DrawLineDepth(
ARect.Right - 1, ARect.Top, ARect.Right - 1, ARect.Bottom - 1, scaledDepth);
end;
end;
var
ext2: TDoubleRect;
p: TDoublePoint;
procedure BuildBar(x1, x2, y, barH: Double);
var
graphBar: TDoubleRect;
imageBar: TRect;
begin
graphBar := DoubleRect(x1, y - barH, x2, y + barH);
if IsRotated then
with graphBar do begin
Exchange(a.X, a.Y);
Exchange(b.X, b.Y);
end;
if not RectIntersectsRect(graphBar, ext2) then exit;
with imageBar do begin
TopLeft := ParentChart.GraphToImage(graphBar.a);
BottomRight := ParentChart.GraphToImage(graphBar.b);
TAGeometry.NormalizeRect(imageBar);
if IsRotated then inc(imageBar.Right) else inc(imageBar.Bottom);
// Draw a line instead of an empty rectangle.
if (Left = Right) and IsRotated then Dec(Left);
if (Bottom = Top) and not IsRotated then Inc(Bottom);
end;
DrawBar(imageBar);
end;
var
x1, x2, h: Double;
begin
if IsEmpty or (not Active) then exit;
ext2 := ParentChart.CurrentExtent;
ExpandRange(ext2.a.X, ext2.b.X, 1.0);
ExpandRange(ext2.a.Y, ext2.b.Y, 1.0);
scaledDepth := ADrawer.Scale(Depth);
PrepareGraphPoints(ext2, true);
for pointIndex := FLoBound to FUpBound do begin
p := Source[pointIndex]^.Point;
if SkipMissingValues(pointIndex) then
continue;
p.Y := AxisToGraphY(p.Y);
h := CalcBarHeight;
with Source[pointIndex]^ do
begin
x1 := AxisToGraphX(GetX(0));
x2 := AxisToGraphX(GetX(1));
end;
BuildBar(x1, x2, p.Y, h);
end;
DrawLabels(ADrawer);
end;
function TStateSeries.Extent: TDoubleRect;
var
y, h: Double;
i: Integer;
begin
// Result := inherited Extent;
Result := Source.ExtentXYList;
if FChart = nil then
raise EStateSeriesError.Create('Calculation of TStateTimeSeries.Extent is not possible when the series is not added to a chart.');
if IsEmpty then exit;
// Show bars fully
h := calcBarHeight;
if Source.YCount = 0 then begin
Result.a.Y -= h;
Result.b.Y += h;
end else begin
i := 0;
y := NearestYNumber(i, -1); // --> y is in graph units
if not IsNan(y) then
Result.a.Y := Min(Result.a.Y, GraphToAxisY(y - h));
i := Count-1;
y := NearestYNumber(i, +1);
if not IsNaN(y) then
Result.b.Y := Max(Result.b.Y, GraphToAxisY(y + h));
end;
end;
function TStateSeries.GetImgBarHeight(AIndex: Integer): Integer;
var
h: Double;
f: TGraphToImageFunc;
begin
h := CalcBarHeight;
if IsRotated then
f := @FChart.YGraphToImage
else
f := @FChart.XGraphToImage;
Result := Abs(f(2 * h) - f(0));
end;
function TStateSeries.GetLabelDataPoint(AIndex, AYIndex: Integer): TDoublePoint;
var
P1, P2: TDoublePoint;
begin
P1 := GetGraphPoint(AIndex, 0, AYIndex);
P2 := GetGraphPoint(AIndex, 1, AYIndex);
if IsRotated then
Result := DoublePoint(P1.X, (P1.Y + P2.Y) / 2)
else
Result := DoublePoint((P1.X + P2.X) / 2, P1.Y);
end;
procedure TStateSeries.GetLegendItems(AItems: TChartLegendItems);
begin
GetLegendItemsRect(AItems, BarBrush, BarPen);
end;
function TStateSeries.GetNearestPoint(const AParams: TNearestPointParams;
out AResults: TNearestPointResults): Boolean;
var
pointIndex: Integer;
graphClickPt: TDoublePoint;
sp: TDoublePoint;
p1, p2, h: Double;
img1, img2, imgClick: Integer;
begin
Result := false;
AResults.FDist := Sqr(AParams.FRadius) + 1;
AResults.FIndex := -1;
AResults.FXIndex := 0;
AResults.FYIndex := 0;
// clicked point in image units
graphClickPt := ParentChart.ImageToGraph(AParams.FPoint);
// Iterate through all points of the series
for pointIndex := 0 to Count - 1 do begin
sp := Source[pointIndex]^.Point;
if IsNaN(sp) then
Continue;
if Source.YCount = 0 then
sp.Y := pointIndex;
sp := AxisToGraph(sp);
h := CalcBarHeight;
if IsRotated then
begin
if not InRange(graphClickPt.X, sp.X - h, sp.X + h) then
Continue;
with Source[pointIndex]^ do
begin
p1 := AxisToGraphY(GetX(0));
p2 := AxisToGraphY(GetX(1));
end;
img1 := ParentChart.YGraphToImage(p1);
img2 := ParentChart.YGraphToImage(p2);
imgClick := AParams.FPoint.Y;
end else
begin
if not InRange(graphClickPt.Y, sp.Y - h, sp.Y + h) then
continue;
with Source[pointIndex]^ do
begin
p1 := AxisToGraphX(GetX(0));
p2 := AxisToGraphX(GetX(1));
end;
img1 := ParentChart.XGraphToImage(p1);
img2 := ParentChart.XGraphToImage(p2);
imgClick := AParams.FPoint.X;
end;
// Checking start point
if (nptPoint in AParams.FTargets) and (nptPoint in ToolTargets) and
InRange(imgClick, img1 - AParams.FRadius, img1 + AParams.FRadius) then
begin
AResults.FDist := abs(img1 - imgClick);
AResults.FIndex := pointindex;
AResults.FXIndex := 0;
AResults.FValue := DoublePoint(p1, Source[pointIndex]^.Point.Y);
Result := true;
break;
end;
// Checking end point
if (nptXList in AParams.FTargets) and (nptXList in ToolTargets) and
InRange(imgClick, img2 - AParams.FRadius, img2 + AParams.FRadius) then
begin
AResults.FDist := abs(img2 - imgClick);
AResults.FIndex := pointIndex;
AResults.FXIndex := 1;
AResults.FValue := DoublePoint(Source[pointindex]^.GetX(1), Source[pointindex]^.Y);
Result := true;
break;
end;
// Checking interior
if IsRotated then
Exchange(img1, img2);
if (nptCustom in AParams.FTargets) and (nptCustom in ToolTargets) and
InRange(imgClick, img1, img2) then
begin
AResults.FDist := abs((img1 + img2) div 2 - imgClick);
AResults.FIndex := pointIndex;
AResults.FXIndex := -1;
AResults.FValue := DoublePoint((Source[pointIndex]^.GetX(0) + Source[pointIndex]^.GetX(1))/2, Source[pointIndex]^.Y);
Result := true;
break;
end;
end;
if Result then
begin
AResults.FYIndex := 0;
AResults.FImg := AParams.FPoint;
end;
end;
class procedure TStateSeries.GetXYCountNeeded(out AXCount, AYCount: Cardinal);
begin
AXCount := 2;
AYCount := 1;
end;
function TStateSeries.GetYRange: Double;
var
ymin, ymax: Double;
begin
Source.YRange(0, ymin{%H-}, ymax{%H-});
Result := ymax - ymin;
end;
function TStateSeries.IsStoredBarHeight: Boolean;
begin
Result := (FBarHeight > 0);
end;
procedure TStateSeries.MovePointEx(var AIndex: Integer;
AXIndex, AYIndex: Integer; const ANewPos: TDoublePoint);
var
np: TDoublePoint;
x1, x2, dx: Double;
begin
Unused(AYIndex);
if not InRange(AIndex, 0, Count - 1) then
exit;
x1 := XValues[AIndex, 0];
x2 := XValues[AIndex, 1];
dx := (x2 - x1) / 2;
np := GraphToAxis(ANewPos);
ParentChart.DisableRedrawing;
try
case AXIndex of
-1: begin
x1 := np.X - dx;
x2 := np.X + dx;
end;
0: x1 := np.X;
1: x2 := np.X;
end;
EnsureOrder(x1, x2);
with ListSource.Item[AIndex]^ do
begin
SetX(0, x1);
SetX(1, x2);
end;
finally
ParentChart.EnableRedrawing;
UpdateParentChart;
end;
end;
function TStateSeries.NearestYNumber(var AIndex: Integer; ADir: Integer): Double;
begin
while InRange(AIndex, 0, Count - 1) do
with Source[AIndex]^ do
if IsNan(Y) then
AIndex += ADir
else
exit(AxisToGraphY(Y));
Result := SafeNan;
end;
procedure TStateSeries.SetBarHeight(AValue: Double);
begin
if FBarHeight = AValue then
exit;
FBarHeight := AValue;
UpdateParentChart;
end;
procedure TStateSeries.SetBarBrush(AValue: TBrush);
begin
FBarBrush.Assign(AValue);
end;
procedure TStateSeries.SetBarPen(AValue: TPen);
begin
FBarPen.Assign(AValue);
end;
initialization
RegisterSeriesClass(TBubbleSeries, @rsBubbleSeries);
RegisterSeriesClass(TBoxAndWhiskerSeries, @rsBoxAndWhiskerSeries);
RegisterSeriesClass(TOpenHighLowCloseSeries, @rsOpenHighLowCloseSeries);
RegisterSeriesClass(TFieldSeries, @rsFieldSeries);
RegisterSeriesClass(TStateSeries, @rsStateSeries);
end.

543
components/tachart/tastateseries.pas
View File

@ -1,543 +0,0 @@
unit TAStateSeries;
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils, Types, Math, Graphics,
TAChartUtils, TADrawUtils, TAMath, TAGeometry, TALegend, TACustomSeries;
type
EStateTimeSeriesError = class(EChartError);
TBarHeightStyle = (bhsPercent, bhsPercentMin);
TStateSeries = class(TBasicPointSeries)
private
const
DEFAULT_BAR_HEIGHT_PERCENT = 70;
private
FBarHeightPercent: Integer;
FBarHeightStyle: TBarHeightStyle;
FBrush: TBrush;
FPen: TPen;
procedure SetBarHeightPercent(AValue: Integer);
procedure SetBarHeightStyle(AValue: TBarHeightStyle);
procedure SetBrush(AValue: TBrush);
procedure SetPen(AValue: TPen);
protected
FMinYRange: Double;
procedure CalcBarHeight(AY: Double; AIndex: Integer; out AHeight: Double);
function GetLabelDataPoint(AIndex, AYIndex: Integer): TDoublePoint; override;
procedure GetLegendItems(AItems: TChartLegendItems); override;
function NearestYNumber(var AIndex: Integer; ADir: Integer): Double;
procedure UpdateMinYRange;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Assign(ASource: TPersistent); override;
function AddXY(AStart, AEnd, Y: Double; ALabel: String;
AColor: TColor = clTAColor): Integer;
procedure Draw(ADrawer: IChartDrawer); override;
function Extent: TDoubleRect; override;
function GetBarHeight(AIndex: Integer): Integer;
function GetNearestPoint(const AParams: TNearestPointParams;
out AResults: TNearestPointResults): Boolean; override;
function GetYRange(AY: Double; AIndex: Integer): Double;
procedure MovePointEx(var AIndex: Integer; AXIndex, AYIndex: Integer;
const ANewPos: TDoublePoint); override;
class procedure GetXYCountNeeded(out AXCount, AYCount: Cardinal); override;
published
property BarHeightPercent: Integer read FBarHeightPercent
write SetBarHeightPercent default DEFAULT_BAR_HEIGHT_PERCENT;
property BarHeightStyle: TBarHeightStyle read FBarHeightStyle
write SetBarHeightStyle default bhsPercent;
property Brush: TBrush read FBrush write SetBrush;
property Pen: TPen read FPen write SetPen;
property MarkPositions;
property Marks;
property ToolTargets default [nptPoint, nptXList, nptCustom];
end;
implementation
uses
TAChartStrConsts, TAGraph;
constructor TStateSeries.Create(AOwner: TComponent);
begin
inherited;
FPen := TPen.Create;
FPen.OnChange := @StyleChanged;
FPen.Color := clBlack;
FBrush := TBrush.Create;
FBrush.OnChange := @StyleChanged;
FBrush.Color := clRed;
FBarHeightPercent := DEFAULT_BAR_HEIGHT_PERCENT;
FBarHeightStyle := bhsPercent;
ToolTargets := [nptPoint, nptXList, nptCustom];
end;
destructor TStateSeries.Destroy;
begin
FBrush.Free;
FPen.Free;
inherited;
end;
function TStateSeries.AddXY(AStart, AEnd, Y: Double;
ALabel: String; AColor: TColor = clTAColor): Integer;
begin
EnsureOrder(AStart, AEnd);
Result := ListSource.AddXListY([AStart, AEnd], Y, ALabel, AColor);
end;
procedure TStateSeries.Assign(ASource: TPersistent);
begin
if ASource is TStateSeries then
with TStateSeries(ASource) do begin
Self.BarHeightPercent := FBarHeightPercent;
Self.BarHeightStyle := FBarHeightStyle;
Self.Brush.Assign(FBrush);
Self.Pen.Assign(FPen);
end;
inherited Assign(ASource);
end;
procedure TStateSeries.CalcBarHeight(AY: Double; AIndex: Integer;
out AHeight: Double);
var
r: Double;
begin
case BarHeightStyle of
bhsPercent : r := GetYRange(AY, AIndex) * PERCENT;
bhsPercentMin : r := FMinYRange * PERCENT;
else
raise EStateTimeSeriesError.Create('BarHeightStyle not implemented'){%H-};
end;
AHeight := r * BarHeightPercent / 2;
end;
procedure TStateSeries.Draw(ADrawer: IChartDrawer);
var
pointIndex: Integer;
scaledDepth: Integer;
procedure DrawBar(const ARect: TRect);
var
sz: TSize;
c: TColor;
// ic: IChartTCanvasDrawer; -- maybe later...
begin
ADrawer.Pen := FPen;
if FPen.Color = clDefault then
ADrawer.SetPenColor(FChart.GetDefaultColor(dctFont))
else
ADrawer.SetPenColor(FPen.Color);
ADrawer.Brush := FBrush;
if FBrush.Color = clDefault then
ADrawer.SetBrushColor(FChart.GetDefaultColor(dctBrush))
else
ADrawer.SetPenColor(FPen.Color);
c := Source[pointIndex]^.Color;
if c <> clTAColor then
ADrawer.BrushColor := c;
sz := Size(ARect);
if (sz.cx <= 2*FPen.Width) or (sz.cy <= 2*FPen.Width) then begin
// Bars are too small to distinguish the border from the interior.
ADrawer.SetPenParams(psSolid, ADrawer.BrushColor);
end;
(* todo --- add me
if Assigned(FOnCustomDrawBar) then begin
FOnCustomDrawBar(Self, ADrawer, AR, pointIndex, stackIndex);
exit;
end;
if Supports(ADrawer, IChartTCanvasDrawer, ic) and Assigned(OnBeforeDrawBar) then
OnBeforeDrawBar(Self, ic.Canvas, AR, pointIndex, stackIndex, defaultDrawing);
if not defaultDrawing then exit; *)
ADrawer.Rectangle(ARect);
if scaledDepth > 0 then begin
c := ADrawer.BrushColor;
ADrawer.BrushColor := GetDepthColor(c, true);
ADrawer.DrawLineDepth(
ARect.Left, ARect.Top, ARect.Right - 1, ARect.Top, scaledDepth);
ADrawer.BrushColor := GetDepthColor(c, false);
ADrawer.DrawLineDepth(
ARect.Right - 1, ARect.Top, ARect.Right - 1, ARect.Bottom - 1, scaledDepth);
end;
end;
var
ext2: TDoubleRect;
h: Double;
p: TDoublePoint;
procedure BuildBar(x1, x2, y: Double);
var
graphBar: TDoubleRect;
imageBar: TRect;
begin
graphBar := DoubleRect(x1, y - h, x2, y + h);
if IsRotated then
with graphBar do begin
Exchange(a.X, a.Y);
Exchange(b.X, b.Y);
end;
if not RectIntersectsRect(graphBar, ext2) then exit;
with imageBar do begin
TopLeft := ParentChart.GraphToImage(graphBar.a);
BottomRight := ParentChart.GraphToImage(graphBar.b);
TAGeometry.NormalizeRect(imageBar);
if IsRotated then inc(imageBar.Right) else inc(imageBar.Bottom);
// Draw a line instead of an empty rectangle.
if (Left = Right) and IsRotated then Dec(Left);
if (Bottom = Top) and not IsRotated then Inc(Bottom);
end;
DrawBar(imageBar);
end;
var
x1, x2: Double;
begin
if IsEmpty or (not Active) then exit;
if BarHeightStyle = bhsPercentMin then
UpdateMinYRange;
ext2 := ParentChart.CurrentExtent;
ExpandRange(ext2.a.X, ext2.b.X, 1.0);
ExpandRange(ext2.a.Y, ext2.b.Y, 1.0);
scaledDepth := ADrawer.Scale(Depth);
PrepareGraphPoints(ext2, true);
for pointIndex := FLoBound to FUpBound do begin
p := Source[pointIndex]^.Point;
if SkipMissingValues(pointIndex) then
continue;
p.Y := AxisToGraphY(p.Y);
CalcBarHeight(p.Y, pointIndex, h);
with Source[pointIndex]^ do
begin
x1 := AxisToGraphX(GetX(0));
x2 := AxisToGraphX(GetX(1));
end;
BuildBar(x1, x2, p.Y);
end;
DrawLabels(ADrawer);
end;
function TStateSeries.Extent: TDoubleRect;
var
y, h: Double;
i: Integer;
begin
// Result := inherited Extent;
Result := Source.ExtentXYList;
if FChart = nil then
raise EStateTimeSeriesError.Create('Calculation of TStateTimeSeries.Extent is not possible when the series is not added to a chart.');
if IsEmpty then exit;
if BarHeightStyle = bhsPercentMin then
UpdateMinYRange;
// Show lowest and highest bars fully.
if Source.YCount = 0 then begin
CalcBarHeight(0.0, 0, h);
Result.a.Y -= h;
Result.b.Y += h;
end else begin
i := 0;
y := NearestYNumber(i, +1); // --> y is in graph units
if not IsNan(y) then begin
CalcBarHeight(y, i, h);
y := GraphToAxisY(y - h); // y is in graph units, Extent in axis units!
Result.a.Y := Min(Result.a.Y, y);
end;
i := Count - 1;
y := NearestYNumber(i, -1);
if not IsNan(y) then begin
CalcBarHeight(y, i, h);
y := GraphToAxisY(y + h);
Result.b.Y := Max(Result.b.Y, y);
end;
end;
end;
function TStateSeries.GetBarHeight(AIndex: Integer): Integer;
var
h: Double;
f: TGraphToImageFunc;
begin
CalcBarHeight(GetGraphPointX(AIndex), AIndex, h);
if IsRotated then
f := @FChart.YGraphToImage
else
f := @FChart.XGraphToImage;
Result := Abs(f(2 * h) - f(0));
end;
function TStateSeries.GetLabelDataPoint(AIndex, AYIndex: Integer): TDoublePoint;
var
P1, P2: TDoublePoint;
begin
P1 := GetGraphPoint(AIndex, 0, AYIndex);
P2 := GetGraphPoint(AIndex, 1, AYIndex);
if IsRotated then
Result := DoublePoint(P1.X, (P1.Y + P2.Y) / 2)
else
Result := DoublePoint((P1.X + P2.X) / 2, P1.Y);
end;
procedure TStateSeries.GetLegendItems(AItems: TChartLegendItems);
begin
GetLegendItemsRect(AItems, Brush, Pen);
end;
function TStateSeries.GetNearestPoint(const AParams: TNearestPointParams;
out AResults: TNearestPointResults): Boolean;
var
pointIndex: Integer;
graphClickPt: TDoublePoint;
sp: TDoublePoint;
p1, p2, h: Double;
img1, img2, imgClick: Integer;
begin
Result := false;
AResults.FDist := Sqr(AParams.FRadius) + 1;
AResults.FIndex := -1;
AResults.FXIndex := 0;
AResults.FYIndex := 0;
// clicked point in image units
graphClickPt := ParentChart.ImageToGraph(AParams.FPoint);
// Iterate through all points of the series
for pointIndex := 0 to Count - 1 do begin
sp := Source[pointIndex]^.Point;
if IsNaN(sp) then
Continue;
if Source.YCount = 0 then
sp.Y := pointIndex;
sp := AxisToGraph(sp);
if IsRotated then
begin
CalcBarHeight(sp.X, pointIndex, h);
if not InRange(graphClickPt.X, sp.X - h, sp.X + h) then
Continue;
with Source[pointIndex]^ do
begin
p1 := AxisToGraphY(GetX(0));
p2 := AxisToGraphY(GetX(1));
end;
img1 := ParentChart.YGraphToImage(p1);
img2 := ParentChart.YGraphToImage(p2);
imgClick := AParams.FPoint.Y;
end else
begin
CalcBarHeight(sp.Y, pointIndex, h); // works with graph units
if not InRange(graphClickPt.Y, sp.Y - h, sp.Y + h) then
continue;
with Source[pointIndex]^ do
begin
p1 := AxisToGraphX(GetX(0));
p2 := AxisToGraphX(GetX(1));
end;
img1 := ParentChart.XGraphToImage(p1);
img2 := ParentChart.XGraphToImage(p2);
imgClick := AParams.FPoint.X;
end;
// Checking start point
if (nptPoint in AParams.FTargets) and (nptPoint in ToolTargets) and
InRange(imgClick, img1 - AParams.FRadius, img1 + AParams.FRadius) then
begin
AResults.FDist := abs(img1 - imgClick);
AResults.FIndex := pointindex;
AResults.FXIndex := 0;
AResults.FValue := DoublePoint(p1, Source[pointIndex]^.Point.Y);
Result := true;
break;
end;
// Checking end point
if (nptXList in AParams.FTargets) and (nptXList in ToolTargets) and
InRange(imgClick, img2 - AParams.FRadius, img2 + AParams.FRadius) then
begin
AResults.FDist := abs(img2 - imgClick);
AResults.FIndex := pointIndex;
AResults.FXIndex := 1;
AResults.FValue := DoublePoint(Source[pointindex]^.GetX(1), Source[pointindex]^.Y);
Result := true;
break;
end;
// Checking interior
if IsRotated then
Exchange(img1, img2);
if (nptCustom in AParams.FTargets) and (nptCustom in ToolTargets) and
InRange(imgClick, img1, img2) then
begin
AResults.FDist := abs((img1 + img2) div 2 - imgClick);
AResults.FIndex := pointIndex;
AResults.FXIndex := -1;
AResults.FValue := DoublePoint((Source[pointIndex]^.GetX(0) + Source[pointIndex]^.GetX(1))/2, Source[pointIndex]^.Y);
Result := true;
break;
end;
end;
if Result then
begin
AResults.FYIndex := 0;
AResults.FImg := AParams.FPoint;
end;
end;
class procedure TStateSeries.GetXYCountNeeded(out AXCount, AYCount: Cardinal);
begin
AXCount := 2;
AYCount := 1;
end;
function TStateSeries.GetYRange(AY: Double; AIndex: Integer): Double;
var
hb, ht: Double;
i: Integer;
begin
if Source.YCount > 0 then begin
i := AIndex - 1;
hb := Abs(AY - NearestYNumber(i, -1));
i := AIndex + 1;
ht := Abs(AY - NearestYNumber(i, +1));
Result := NumberOr(SafeMin(hb, ht), 1.0);
if Result = 0.0 then
Result := 1.0;
end else
Result := 1.0;
end;
procedure TStateSeries.MovePointEx(var AIndex: Integer;
AXIndex, AYIndex: Integer; const ANewPos: TDoublePoint);
var
np: TDoublePoint;
x1, x2, dx: Double;
begin
Unused(AYIndex);
if not InRange(AIndex, 0, Count - 1) then
exit;
x1 := XValues[AIndex, 0];
x2 := XValues[AIndex, 1];
dx := (x2 - x1) / 2;
np := GraphToAxis(ANewPos);
ParentChart.DisableRedrawing;
try
case AXIndex of
-1: begin
x1 := np.X - dx;
x2 := np.X + dx;
end;
0: x1 := np.X;
1: x2 := np.X;
end;
EnsureOrder(x1, x2);
with ListSource.Item[AIndex]^ do
begin
SetX(0, x1);
SetX(1, x2);
end;
finally
ParentChart.EnableRedrawing;
UpdateParentChart;
end;
end;
function TStateSeries.NearestYNumber(var AIndex: Integer; ADir: Integer): Double;
begin
while InRange(AIndex, 0, Count - 1) do
with Source[AIndex]^ do
if IsNan(Y) then
AIndex += ADir
else
exit(AxisToGraphY(Y));
Result := SafeNan;
end;
procedure TStateSeries.SetBarHeightPercent(AValue: Integer);
begin
if FBarHeightPercent = AValue then
exit;
if (csDesigning in ComponentState) and (AValue < 1) or (AValue > 100) then
raise EStateTimeSeriesError.Create('Wrong BarHeight Percent');
FBarHeightPercent := EnsureRange(AValue, 1, 100);
UpdateParentChart;
end;
procedure TStateSeries.SetBarHeightStyle(AValue: TBarHeightStyle);
begin
if FBarHeightStyle = AValue then
exit;
FBarHeightStyle := AValue;
UpdateParentChart;
end;
procedure TStateSeries.SetBrush(AValue: TBrush);
begin
FBrush.Assign(AValue);
end;
procedure TStateSeries.SetPen(AValue: TPen);
begin
FPen.Assign(AValue);
end;
procedure TStateSeries.UpdateMinYRange;
var
Y, prevY: Double;
i: Integer;
begin
if (Count < 2) or (Source.YCount = 0) then begin
FMinYRange := 1.0;
exit;
end;
Y := Source[0]^.Y;
prevY := Source[1]^.Y;
FMinYRange := Abs(Y - prevY);
for i := 2 to Count - 1 do begin
Y := Source[i]^.Y;
FMinYRange := SafeMin(Abs(Y - prevY), FMinYRange);
prevY := Y;
end;
end;
initialization
RegisterSeriesClass(TStateSeries, @rsStateSeries);
end.