paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-27 02:53:40 +02:00
Code Issues Packages Projects Releases Wiki Activity
d20e7ffb5f
lazarus/components/tachart/taseries.pas

2500 lines
72 KiB
ObjectPascal
Raw Blame History

{
/***************************************************************************
TASeries.pas
------------
Component Library Standard Graph Series
***************************************************************************/
*****************************************************************************
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
Authors: Luís Rodrigues, Philippe Martinole, Alexander Klenin
}
unit TASeries;
{$H+}
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}
interface
uses
Classes, Graphics, Types,
TAChartUtils, TADrawUtils, TACustomSeries, TALegend, TARadialSeries, TATypes,
TAChartAxis;
const
DEF_BAR_WIDTH_PERCENT = 70;
type
EBarError = class(EChartError);
TBarShape = (bsRectangular, bsCylindrical, bsHexPrism, bsPyramid, bsConical);
TBarWidthStyle = (bwPercent, bwPercentMin);
TBarSeries = class;
TBeforeDrawBarEvent = procedure (
ASender: TBarSeries; ACanvas: TCanvas; const ARect: TRect;
APointIndex, AStackIndex: Integer; var ADoDefaultDrawing: Boolean
) of object; deprecated;
TCustomDrawBarEvent = procedure (
ASeries: TBarSeries; ADrawer: IChartDrawer; const ARect: TRect;
APointIndex, AStackIndex: Integer) of object;
{ TBarSeries }
TBarSeries = class(TBasicPointSeries)
private
type
TDrawBarProc = procedure (ADrawer: IChartDrawer; const ARect: TRect; ADepth: Integer) of object;
private
FBarBrush: TBrush;
FBarOffsetPercent: Integer;
FBarPen: TPen;
FBarShape: TBarShape;
FBarWidthPercent: Integer;
FBarWidthStyle: TBarWidthStyle;
FOnBeforeDrawBar: TBeforeDrawBarEvent;
FOnCustomDrawBar: TCustomDrawBarEvent;
FUseZeroLevel: Boolean;
FZeroLevel: Double;
FDrawBarProc: TDrawBarProc;
function IsZeroLevelStored: boolean;
procedure SetBarBrush(Value: TBrush);
procedure SetBarOffsetPercent(AValue: Integer);
procedure SetBarPen(Value: TPen);
procedure SetBarShape(AValue: TBarShape);
procedure SetBarWidthPercent(Value: Integer);
procedure SetBarWidthStyle(AValue: TBarWidthStyle);
procedure SetOnBeforeDrawBar(AValue: TBeforeDrawBarEvent);
procedure SetOnCustomDrawBar(AValue: TCustomDrawBarEvent);
procedure SetSeriesColor(AValue: TColor);
procedure SetUseZeroLevel(AValue: Boolean);
procedure SetZeroLevel(AValue: Double);
protected
procedure BarOffsetWidth(
AX: Double; AIndex: Integer; out AOffset, AWidth: Double);
procedure DrawConicalBar(ADrawer: IChartDrawer; const ARect: TRect; ADepth: Integer);
procedure DrawCylinderBar(ADrawer: IChartDrawer; const ARect: TRect; ADepth: Integer);
procedure DrawHexPrism(ADrawer: IChartDrawer; const ARect: TRect; ADepth: Integer);
procedure DrawPyramidBar(ADrawer: IChartDrawer; const ARect: TRect; ADepth: Integer);
procedure DrawRectBar(ADrawer: IChartDrawer; const ARect: TRect; ADepth: Integer);
function GetLabelDataPoint(AIndex, AYIndex: Integer): TDoublePoint; override;
procedure GetLegendItems(AItems: TChartLegendItems); override;
function GetSeriesColor: TColor; override;
function GetZeroLevel: Double; override;
function ToolTargetDistance(const AParams: TNearestPointParams;
AGraphPt: TDoublePoint; APointIdx, AXIdx, AYIdx: Integer): Integer; override;
procedure UpdateMargins(ADrawer: IChartDrawer; var AMargins: TRect); override;
public
procedure Assign(ASource: TPersistent); override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
public
procedure Draw(ADrawer: IChartDrawer); override;
function Extent: TDoubleRect; override;
function GetBarWidth(AIndex: Integer): Integer;
function GetNearestPoint(const AParams: TNearestPointParams;
out AResults: TNearestPointResults): Boolean; override;
published
property AxisIndexX;
property AxisIndexY;
property BarBrush: TBrush read FBarBrush write SetBarBrush;
property BarOffsetPercent: Integer
read FBarOffsetPercent write SetBarOffsetPercent default 0;
property BarPen: TPen read FBarPen write SetBarPen;
property BarShape: TBarShape read FBarshape write SetBarShape default bsRectangular;
property BarWidthPercent: Integer
read FBarWidthPercent write SetBarWidthPercent default DEF_BAR_WIDTH_PERCENT;
property BarWidthStyle: TBarWidthStyle
read FBarWidthStyle write SetBarWidthStyle default bwPercent;
property Depth;
property DepthBrightnessDelta;
property MarkPositionCentered;
property MarkPositions;
property Marks;
property SeriesColor: TColor
read GetSeriesColor write SetSeriesColor stored false default clRed;
property Source;
property Stacked default true;
property StackedNaN;
property Styles;
property ToolTargets default [nptPoint, nptYList, nptCustom];
property UseZeroLevel: Boolean
read FUseZeroLevel write SetUseZeroLevel default true;
property ZeroLevel: Double
read FZeroLevel write SetZeroLevel stored IsZeroLevelStored;
published
property OnBeforeDrawBar: TBeforeDrawBarEvent
read FOnBeforeDrawBar write SetOnBeforeDrawBar; deprecated 'Use OnCustomDrawBar instead';
property OnCustomDrawBar: TCustomDrawBarEvent
read FOnCustomDrawBar write SetOnCustomDrawBar;
end;
{ TPieSeries }
TPieSeries = class(TCustomPieSeries)
public
property Radius;
published
property AngleRange;
property EdgePen;
property Depth;
property DepthBrightnessDelta;
property Exploded;
property FixedRadius;
property InnerRadiusPercent;
property MarkDistancePercent;
property MarkPositionCentered;
property MarkPositions;
property Marks;
property Orientation;
property RotateLabels;
property StartAngle;
property Source;
property ViewAngle;
property OnCustomDrawPie;
end;
TConnectType = (ctLine, ctStepXY, ctStepYX);
{ TAreaSeries }
TAreaSeries = class(TBasicPointSeries)
private
FAreaBrush: TBrush;
FAreaContourPen: TPen;
FAreaLinesPen: TPen;
FBanded: Boolean;
FConnectType: TConnectType;
FUseZeroLevel: Boolean;
FZeroLevel: Double;
function IsZeroLevelStored: boolean;
procedure SetAreaBrush(AValue: TBrush);
procedure SetAreaContourPen(AValue: TPen);
procedure SetAreaLinesPen(AValue: TPen);
procedure SetBanded(AValue: Boolean);
procedure SetConnectType(AValue: TConnectType);
procedure SetSeriesColor(AValue: TColor);
procedure SetUseZeroLevel(AValue: Boolean);
procedure SetZeroLevel(AValue: Double);
protected
procedure GetLegendItems(AItems: TChartLegendItems); override;
function GetSeriesColor: TColor; override;
function GetZeroLevel: Double; override;
function SkipMissingValues(AIndex: Integer): Boolean; override;
public
procedure Assign(ASource: TPersistent); override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Draw(ADrawer: IChartDrawer); override;
function Extent: TDoubleRect; override;
published
property AxisIndexX;
property AxisIndexY;
published
property AreaBrush: TBrush read FAreaBrush write SetAreaBrush;
property AreaContourPen: TPen read FAreaContourPen write SetAreaContourPen;
property AreaLinesPen: TPen read FAreaLinesPen write SetAreaLinesPen;
property Banded: Boolean read FBanded write SetBanded default false;
property ConnectType: TConnectType
read FConnectType write SetConnectType default ctLine;
property Depth;
property DepthBrightnessDelta;
property MarkPositionCentered;
property MarkPositions;
property Marks;
property SeriesColor: TColor
read GetSeriesColor write SetSeriesColor stored false default clWhite;
property Source;
property Stacked default true;
property StackedNaN;
property Styles;
property ToolTargets;
property UseZeroLevel: Boolean
read FUseZeroLevel write SetUseZeroLevel default false;
property ZeroLevel: Double
read FZeroLevel write SetZeroLevel stored IsZeroLevelStored;
end;
TSeriesPointerDrawEvent = procedure (
ASender: TChartSeries; ACanvas: TCanvas; AIndex: Integer;
ACenter: TPoint) of object;
TLineType = (ltNone, ltFromPrevious, ltFromOrigin, ltStepXY, ltStepYX);
TColorEachMode = (ceNone, cePoint, ceLineBefore, ceLineAfter,
cePointAndLineBefore, cePointAndLineAfter);
{ TLineSeries }
TLineSeries = class(TBasicPointSeries)
private
FLinePen: TPen;
FLineType: TLineType;
FOldLineType: TLineType;
FOnDrawPointer: TSeriesPointerDrawEvent;
FColorEach: TColorEachMode;
procedure DrawSingleLineInStack(ADrawer: IChartDrawer; AIndex: Integer);
function GetShowLines: Boolean;
function GetShowPoints: Boolean;
procedure SetColorEach(AValue: TColorEachMode);
procedure SetLinePen(AValue: TPen);
procedure SetLineType(AValue: TLineType);
procedure SetSeriesColor(AValue: TColor);
procedure SetShowLines(Value: Boolean);
procedure SetShowPoints(AValue: Boolean);
protected
procedure AfterDrawPointer(
ADrawer: IChartDrawer; AIndex: Integer; const APos: TPoint); override;
procedure GetLegendItems(AItems: TChartLegendItems); override;
function GetSeriesColor: TColor; override;
public
procedure Assign(ASource: TPersistent); override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Draw(ADrawer: IChartDrawer); override;
function GetNearestPoint(const AParams: TNearestPointParams;
out AResults: TNearestPointResults): Boolean; override;
published
property AxisIndexX;
property AxisIndexY;
property ColorEach: TColorEachMode
read FColorEach write SetColorEach default cePoint;
property Depth;
property DepthBrightnessDelta;
property LinePen: TPen read FLinePen write SetLinePen;
property LineType: TLineType
read FLineType write SetLineType default ltFromPrevious;
property MarkPositions;
property Marks;
property Pointer;
property SeriesColor: TColor
read GetSeriesColor write SetSeriesColor stored false default clBlack;
property ShowLines: Boolean
read GetShowLines write SetShowLines stored false default true;
property ShowPoints: Boolean
read GetShowPoints write SetShowPoints default false;
property Stacked default false;
property StackedNaN;
property Source;
property Styles;
property ToolTargets;
property XErrorBars;
property YErrorBars;
// Events
property OnCustomDrawPointer;
property OnGetPointerStyle;
end;
// Scatter plot displaying a single pixel per data point.
// Optimized to work efficiently for millions of points.
// See http://en.wikipedia.org/wiki/Manhattan_plot
TManhattanSeries = class(TBasicPointSeries)
private
FSeriesColor: TColor;
procedure SetSeriesColor(AValue: TColor);
protected
procedure GetLegendItems(AItems: TChartLegendItems); override;
public
procedure Assign(ASource: TPersistent); override;
procedure Draw(ADrawer: IChartDrawer); override;
published
property AxisIndexX;
property AxisIndexY;
property SeriesColor: TColor
read FSeriesColor write SetSeriesColor default clBlack;
property Source;
end;
TLineStyle = (lsVertical, lsHorizontal);
{ TConstantLine }
TConstantLine = class(TCustomChartSeries)
strict private
FArrow: TChartArrow;
FLineStyle: TLineStyle;
FPen: TPen;
FPosition: Double; // Graph coordinate of line
FUseBounds: Boolean;
function GetAxisIndex: TChartAxisIndex;
function GetSeriesColor: TColor;
procedure SavePosToCoord(var APoint: TDoublePoint);
procedure SetArrow(AValue: TChartArrow);
procedure SetAxisIndex(AValue: TChartAxisIndex);
procedure SetLineStyle(AValue: TLineStyle);
procedure SetPen(AValue: TPen);
procedure SetPosition(AValue: Double);
procedure SetSeriesColor(AValue: TColor);
procedure SetUseBounds(AValue: Boolean);
protected
procedure AfterAdd; override;
procedure GetBounds(var ABounds: TDoubleRect); override;
procedure GetLegendItems(AItems: TChartLegendItems); override;
public
procedure Assign(ASource: TPersistent); override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Draw(ADrawer: IChartDrawer); override;
function GetAxisBounds({%H-}AAxis: TChartAxis; out {%H-}AMin, {%H-}AMax: Double): Boolean; override;
function GetNearestPoint(
const AParams: TNearestPointParams;
out AResults: TNearestPointResults): Boolean; override;
function IsEmpty: Boolean; override;
procedure MovePoint(var AIndex: Integer; const ANewPos: TDoublePoint); override;
procedure UpdateBiDiMode; override;
published
property Active default true;
property Arrow: TChartArrow read FArrow write SetArrow;
property AxisIndex: TChartAxisIndex
read GetAxisIndex write SetAxisIndex default DEF_AXIS_INDEX;
property AxisIndexX stored false; deprecated 'Use "AxisIndex"';
property LineStyle: TLineStyle
read FLineStyle write SetLineStyle default lsHorizontal;
property Pen: TPen read FPen write SetPen;
property Position: Double read FPosition write SetPosition;
property SeriesColor: TColor
read GetSeriesColor write SetSeriesColor stored false default clBlack;
property ShowInLegend;
property Title;
property UseBounds: Boolean read FUseBounds write SetUseBounds default true;
property ZPosition;
end;
TSeriesDrawEvent = procedure (ACanvas: TCanvas; const ARect: TRect) of object;
TSeriesGetBoundsEvent = procedure (var ABounds: TDoubleRect) of object;
{ TUserDrawnSeries }
TUserDrawnSeries = class(TCustomChartSeries)
private
FOnDraw: TSeriesDrawEvent;
FOnGetBounds: TSeriesGetBoundsEvent;
procedure SetOnDraw(AValue: TSeriesDrawEvent);
procedure SetOnGetBounds(AValue: TSeriesGetBoundsEvent);
protected
procedure GetBounds(var ABounds: TDoubleRect); override;
procedure GetLegendItems(AItems: TChartLegendItems); override;
public
procedure Assign(ASource: TPersistent); override;
procedure Draw(ADrawer: IChartDrawer); override;
function IsEmpty: Boolean; override;
published
property Active default true;
property ZPosition;
published
property OnDraw: TSeriesDrawEvent read FOnDraw write SetOnDraw;
property OnGetBounds: TSeriesGetBoundsEvent
read FOnGetBounds write SetOnGetBounds;
end;
implementation
uses
{GraphMath,} GraphType, IntfGraphics, LResources, Math, PropEdits, SysUtils,
TAChartStrConsts, TADrawerCanvas, TAGeometry, TACustomSource, TAGraph,
TAMath, TAStyles;
{ TLineSeries }
procedure TLineSeries.AfterDrawPointer(
ADrawer: IChartDrawer; AIndex: Integer; const APos: TPoint);
var
ic: IChartTCanvasDrawer;
begin
if Supports(ADrawer, IChartTCanvasDrawer, ic) and Assigned(FOnDrawPointer) then
FOnDrawPointer(Self, ic.Canvas, AIndex, APos);
end;
procedure TLineSeries.Assign(ASource: TPersistent);
begin
if ASource is TLineSeries then
with TLineSeries(ASource) do begin
Self.LinePen := FLinePen;
Self.FLineType := FLineType;
Self.FOnDrawPointer := FOnDrawPointer;
Self.FColorEach := FColorEach;
end;
inherited Assign(ASource);
end;
constructor TLineSeries.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FColorEach := cePoint;
FLinePen := TPen.Create;
FLinePen.OnChange := @StyleChanged;
FPointer := TSeriesPointer.Create(FChart);
SetPropDefaults(Self, ['LineType']);
FOldLineType := FLineType;
end;
destructor TLineSeries.Destroy;
begin
FreeAndNil(FLinePen);
inherited;
end;
procedure TLineSeries.Draw(ADrawer: IChartDrawer);
procedure RemoveStackedNaN;
var
i, j: Integer;
item: PChartDataItem;
begin
if FStacked and (FStackedNaN = snDoNotDraw) then
for i := 0 to High(FGraphPoints) do begin
item := Source.Item[i + FLoBound];
if not IsNaN(item^.X) then
if IsNaN(item^.Y) then
FGraphPoints[i].X := NaN
else
for j := 0 to Source.YCount-2 do
if IsNaN(item^.YList[j]) then begin
FGraphPoints[i].X := NaN;
break;
end;
end;
end;
var
ext: TDoubleRect;
i: Integer;
begin
if IsEmpty or (not Active) then exit;
with Extent do begin
ext.a := AxisToGraph(a);
ext.b := AxisToGraph(b);
end;
NormalizeRect(ext);
if LineType = ltFromOrigin then
ExpandRect(ext, AxisToGraph(ZeroDoublePoint));
// Do not draw anything if the series extent does not intersect CurrentExtent.
if not RectIntersectsRect(ext, ParentChart.CurrentExtent) then exit;
PrepareGraphPoints(ext, LineType <> ltFromOrigin);
RemoveStackedNaN;
DrawSingleLineInStack(ADrawer, 0);
for i := 0 to Source.YCount - 2 do begin
if Source.IsYErrorIndex(i+1) then Continue;
UpdateGraphPoints(i, FStacked);
RemoveStackedNaN;
DrawSingleLineInStack(ADrawer, i + 1);
end;
end;
procedure TLineSeries.DrawSingleLineInStack(
ADrawer: IChartDrawer; AIndex: Integer);
var
points: array of TPoint;
pointCount: Integer = 0;
breaks: TIntegerDynArray;
breakCount: Integer = 0;
// Drawing long polylines with wide pen is very inefficient on Windows and GTK.
// On Windows it is so bad that trying to draw polyline with 50000 points
// will cause hard freeze of entire OS. (!)
// Also, Windows refuses to draw any polyline with number of points
// above approximately one million.
// So, split long polylines into segments.
function PolylineIsTooLong: Boolean; inline;
// There is a trade-off between the call overhead for short serment and
// the above-mentioned inefficiency for long ones.
// First value was selected by some experiments as "optimal enough" for
// both affected platforms.
{$IF defined(LCLWIN32) or defined(LCLGTK2)}
const
MAX_LENGTH: array [Boolean] of Integer = (50000, 1000000);
{$ENDIF}
begin
{$IF defined(LCLWIN32)}
Result :=
(breakCount > 0) and
(pointCount - breaks[breakCount - 1] > MAX_LENGTH[LinePen.Width = 1]);
{$ELSEIF defined(LCLGTK2)}
Result :=
(LinePen.Width > 1) and (breakCount > 0) and
(pointCount - breaks[breakCount - 1] > MAX_LENGTH[false]);
{$ELSE}
Result := false;
{$ENDIF}
end;
procedure PushPoint(const APoint: TPoint); inline;
begin
if pointCount > High(points) then
SetLength(points, Length(points) * 2);
points[pointCount] := APoint;
pointCount += 1;
end;
procedure CacheLine(AA, AB: TDoublePoint);
var
ai, bi: TPoint;
begin
// This is not an optimization, but a safety check to avoid
// integer overflow with extreme zoom-ins.
if not LineIntersectsRect(AA, AB, ParentChart.CurrentExtent) then exit;
ai := ParentChart.GraphToImage(AA);
bi := ParentChart.GraphToImage(AB);
if ai = bi then exit;
if
(pointCount = 0) or (points[pointCount - 1] <> ai) or PolylineIsTooLong
then begin
breaks[breakCount] := pointCount;
breakCount += 1;
PushPoint(ai);
end;
PushPoint(bi);
end;
procedure DrawStep(const AP1, AP2: TDoublePoint);
var
m: TDoublePoint;
begin
if (LineType = ltStepXY) xor IsRotated then
m := DoublePoint(AP2.X, AP1.Y)
else
m := DoublePoint(AP1.X, AP2.Y);
CacheLine(AP1, m);
CacheLine(m, AP2);
end;
procedure DrawDefaultLines;
var
i, j: Integer;
p, pPrev: TDoublePoint;
pNan, pPrevNan: Boolean;
scaled_depth: Integer;
begin
if LineType = ltNone then exit;
// For extremely long series (10000 points or more), the Canvas.Line call
// becomes a bottleneck. So represent a serie as a sequence of polylines.
// This achieves approximately 3x speedup for the typical case.
SetLength(points, Length(FGraphPoints) + 1);
SetLength(breaks, Length(FGraphPoints) + 1);
pPrevNan := true;
// Actually needed only for ltFromOrigin, but moved to silence a warning.
pPrev := AxisToGraph(ZeroDoublePoint);
case LineType of
ltFromPrevious:
for p in FGraphPoints do begin
pNan := IsNan(p);
if not (pNan or pPrevNan) then
CacheLine(pPrev, p);
pPrev := p;
pPrevNan := pNan;
end;
ltFromOrigin:
for p in FGraphPoints do
if not IsNan(p) then
CacheLine(pPrev, p);
ltStepXY, ltStepYX:
for p in FGraphPoints do begin
pNan := IsNan(p);
if not (pNan or pPrevNan) then
DrawStep(pPrev, p);
pPrev := p;
pPrevNan := pNan;
end;
else
raise EChartError.Create('[TLineSeries.DrawSingleLineInStack] Unhandled LineType');
end;
breaks[breakCount] := pointCount;
breakCount += 1;
SetLength(points, pointCount);
SetLength(breaks, breakCount);
ADrawer.SetBrushParams(bsClear, clTAColor);
ADrawer.Pen := LinePen;
if LinePen.Color = clDefault then
ADrawer.SetPenColor(FChart.GetDefaultColor(dctFont))
else
ADrawer.SetPenColor(LinePen.Color);
if Styles <> nil then
Styles.Apply(ADrawer, AIndex, Depth = 0);
// "true" avoids painting of spaces in non-solid lines in brush color
if Depth = 0 then
for i := 0 to High(breaks) - 1 do
ADrawer.Polyline(points, breaks[i], breaks[i + 1] - breaks[i])
else begin
if Styles = nil then begin
ADrawer.SetBrushParams(bsSolid, GetDepthColor(LinePen.Color));
ADrawer.SetPenParams(LinePen.Style, clBlack);
end;
scaled_depth := ADrawer.Scale(Depth);
for i := 0 to High(breaks) - 1 do
for j := breaks[i] to breaks[i + 1] - 2 do
ADrawer.DrawLineDepth(points[j], points[j + 1], scaled_depth);
end;
end;
function GetPtColor(AIndex: Integer): TColor;
begin
Result := Source[AIndex]^.Color;
if Result = clTAColor then Result := SeriesColor;
end;
procedure DrawColoredLines;
var
i, n: Integer;
gp: TDoublepoint;
col, col1, col2: TColor;
imgPt1, imgPt2: TPoint;
pt, origin: TPoint;
hasBreak: Boolean;
begin
if LineType = ltNone then exit;
n := Length(FGraphPoints);
// Find first point
i := 0;
while (i < n) do begin
gp := FGraphPoints[i];
if not IsNaN(gp) then break;
inc(i);
end;
if i = n then
exit;
ADrawer.Pen := LinePen;
if LinePen.Color = clDefault then
ADrawer.SetPenColor(FChart.GetDefaultColor(dctFont))
else
ADrawer.SetPenColor(LinePen.Color);
imgPt1 := ParentChart.GraphToImage(gp);
col1 := GetPtColor(i + FLoBound);
// First line for line type ltFromOrigin
if LineType = ltFromOrigin then begin
origin := ParentChart.GraphToImage(AxisToGraph(ZeroDoublePoint));
ADrawer.SetPenParams(FLinePen.Style, col1, FLinePen.Width);
ADrawer.Line(origin, imgPt1);
end;
// iterate through all other points
hasBreak := false;
while (i < n) do begin
gp := FGraphPoints[i];
if IsNaN(gp) then begin
hasBreak := true;
end else begin
if hasBreak then begin
imgPt1 := ParentChart.GraphToImage(gp);
hasBreak := false;
end;
imgPt2 := ParentChart.GraphToImage(gp);
col2 := GetPtColor(i + FLoBound);
if imgPt1 <> imgPt2 then begin
case FColorEach of
ceLineBefore, cePointAndLineBefore: col := col2;
ceLineAfter, cePointAndLineAfter: col := col1;
else raise Exception.Create('TLineSeries: ColorEach error');
end;
ADrawer.SetPenParams(FLinePen.Style, col, FLinePen.Width);
case LineType of
ltFromPrevious:
ADrawer.Line(imgPt1, imgPt2);
ltStepXY:
begin
pt := Point(imgPt2.x, imgPt1.Y);
ADrawer.Line(imgPt1, pt);
ADrawer.Line(pt, imgPt2);
end;
ltStepYX:
begin
pt := Point(imgPt1.x, imgPt2.Y);
ADrawer.Line(imgPt1, pt);
ADrawer.Line(pt, imgPt2);
end;
ltFromOrigin:
ADrawer.Line(origin, imgPt2);
else
raise EChartError.Create('[TLineSeries.DrawSingleLineInStack] Unhandled LineType');
end;
end;
imgPt1 := imgPt2;
col1 := col2;
end;
inc(i);
end;
end;
begin
case FColorEach of
ceNone, cePoint:
DrawDefaultLines;
else
DrawColoredLines;
end;
if AIndex = 0 then
DrawErrorBars(ADrawer);
DrawLabels(ADrawer, AIndex);
if ShowPoints then
DrawPointers(ADrawer, AIndex, FColorEach in [cePoint, cePointAndLineBefore, cePointAndLineAfter]);
end;
procedure TLineSeries.GetLegendItems(AItems: TChartLegendItems);
var
lb: TBrush;
lp: TPen;
p: TSeriesPointer;
i: Integer;
li: TLegendItemLinePointer;
s: TChartStyle;
begin
if LineType = ltNone then
lp := nil
else
lp := LinePen;
if ShowPoints then
p := Pointer
else
p := nil;
case Legend.Multiplicity of
lmSingle:
AItems.Add(TLegendItemLinePointer.Create(lp, p, LegendTextSingle));
lmPoint:
for i := 0 to Count - 1 do begin
li := TLegendItemLinePointer.Create(lp, p, LegendTextPoint(i));
li.Color := GetColor(i);
AItems.Add(li);
end;
lmStyle:
if Styles <> nil then begin
if Assigned(p) then lb := p.Brush else lb := nil;
for s in Styles.Styles do
AItems.Add(TLegendItemLinePointer.CreateWithBrush(
TAChartUtils.IfThen((lp <> nil) and s.UsePen, s.Pen, lp) as TPen,
TAChartUtils.IfThen(s.UseBrush, s.Brush, lb) as TBrush,
p,
LegendTextStyle(s)
));
end;
end;
end;
function TLineSeries.GetNearestPoint(const AParams: TNearestPointParams;
out AResults: TNearestPointResults): Boolean;
var
pointIndex, levelIndex: Integer;
ip1, ip2, q: TPoint;
d, dmin: Integer;
isInside: Boolean;
ext: TDoubleRect;
begin
Result := false;
AResults.FDist := sqr(AParams.FRadius) + 1;
AResults.FIndex := -1;
AResults.FXIndex := 0;
AResults.FYIndex := 0;
Result := inherited;
if Result or (LineType <> ltFromPrevious) or
not ((nptCustom in AParams.FTargets) and (nptCustom in ToolTargets))
then
exit;
with Extent do begin
ext.a := AxisToGraph(a);
ext.b := AxisToGraph(b);
end;
NormalizeRect(ext);
// Do not do anything if the series extent does not intersect CurrentExtent.
if not RectIntersectsRect(ext, ParentChart.CurrentExtent) then
exit;
// Iterate through all points of the series and - if nptYList is in Targets -
// at all stack levels.
PrepareGraphPoints(ext, true);
dmin := AResults.FDist;
for levelIndex := 0 to Source.YCount-1 do begin
if levelIndex > 0 then
UpdateGraphPoints(levelIndex, FStacked);
ip1 := ParentChart.GraphToImage(FGraphPoints[0]);
for pointIndex := 1 to FUpBound - FLoBound do begin
ip2 := ParentChart.GraphToImage(FGraphPoints[pointIndex]);
d := PointLineDist(AParams.FPoint, ip1, ip2, q, isInside);
if isInside and (d < dmin) then begin
dmin := d;
AResults.FIndex := -1; //pointIndex + FLoBound;
AResults.FYIndex := levelIndex;
AResults.FImg := q;
AResults.FValue := ParentChart.ImageToGraph(q);
end;
ip1 := ip2;
end;
if not ((nptYList in AParams.FTargets) and (nptYList in ToolTargets)) then
break;
end;
if dmin < AResults.FDist then
begin
AResults.FDist := d;
Result := true;
end;
end;
function TLineSeries.GetSeriesColor: TColor;
begin
Result := FLinePen.Color;
end;
function TLineSeries.GetShowLines: Boolean;
begin
Result := FLineType <> ltNone;
end;
function TLineSeries.GetShowPoints: Boolean;
begin
Result := FPointer.Visible;
end;
procedure TLineSeries.SetColorEach(AValue: TColorEachMode);
begin
if FColorEach = AValue then exit;
FColorEach := AValue;
UpdateParentChart;
end;
procedure TLineSeries.SetLinePen(AValue: TPen);
begin
FLinePen.Assign(AValue);
end;
procedure TLineSeries.SetLineType(AValue: TLineType);
begin
if FLineType = AValue then exit;
FLineType := AValue;
FOldLineType := FLineType;
UpdateParentChart;
end;
procedure TLineSeries.SetSeriesColor(AValue: TColor);
begin
FLinePen.Color := AValue;
end;
procedure TLineSeries.SetShowLines(Value: Boolean);
begin
if ShowLines = Value then exit;
if Value then
FLineType := FOldLineType
else begin
FOldLineType := FLineType;
FLineType := ltNone;
end;
UpdateParentChart;
end;
procedure TLineSeries.SetShowPoints(AValue: Boolean);
begin
if ShowPoints = AValue then exit;
FPointer.Visible := AValue;
UpdateParentChart;
end;
{ TManhattanSeries }
procedure TManhattanSeries.Assign(ASource: TPersistent);
begin
if ASource is TManhattanSeries then
with TManhattanSeries(ASource) do
Self.FSeriesColor := SeriesColor;
inherited Assign(ASource);
end;
procedure TManhattanSeries.Draw(ADrawer: IChartDrawer);
var
img: TLazIntfImage;
topLeft, pt: TPoint;
i, cnt: Integer;
ext: TDoubleRect;
rawImage: TRawImage;
r: TRect;
{ Workaround for issue #38759:
In TColor, the byte layout is - from low to high - "rgba". The rawimage
data block however must have the byte order "bgra". Therefore, we must
exchange r and b to avoid false colors.
Note: It does not work out to init the rawimage by Init_BPP32_R8G8B8A8_BIO_TTB
(rather than by Init_BPP32_B8G8R8A8_BIO_TTB) - no idea why... }
function FixColor(AColor: TChartColor): Cardinal; inline;
type
TQuad = packed array[0..3] of byte;
var
quad: TQuad absolute AColor;
begin
{$IFDEF LCLGTK3}
Result := AColor or $FF000000; // $FF -> Opacity
{$ELSE}
TQuad(Result)[0] := quad[2];
TQuad(Result)[1] := quad[1];
TQuad(Result)[2] := quad[0];
TQuad(Result)[3] := $FF; // Opacity
{$ENDIF}
end;
procedure PutPixel(const APoint: TPoint; AColor: TChartColor);
begin
PCardinal(rawImage.Data)[APoint.Y * r.Right + APoint.X] := FixColor(ColorDef(AColor, SeriesColor));
cnt += 1;
end;
begin
if IsEmpty or (not Active) then exit;
with Extent do begin
ext.a := AxisToGraph(a);
ext.b := AxisToGraph(b);
end;
NormalizeRect(ext);
if not RectIntersectsRect(ext, ParentChart.CurrentExtent) then exit;
// Do not cache graph points to reduce memory overhead.
FindExtentInterval(ext, true);
topLeft := ParentChart.ClipRect.TopLeft;
r := BoundsSize(0, 0, ParentChart.ClipRect.BottomRight - topLeft);
cnt := 0;
img := CreateLazIntfImage(rawImage, r.BottomRight);
try
// AxisToGraph is slow, so split loop to optimize non-transformed case.
if (AxisIndexX = -1) and (AxisIndexY = -1) then
for i := FLoBound to FUpBound do
with Source[i]^ do begin
pt := ParentChart.GraphToImage(Point) - topLeft;
if PtInRect(r, pt) then
PutPixel(pt, Color);
end
else
for i := FLoBound to FUpBound do
with Source[i]^ do begin
pt := ParentChart.GraphToImage(AxisToGraph(Point)) - topLeft;
if PtInRect(r, pt) then
PutPixel(pt, Color);
end;
if cnt > 0 then
ADrawer.PutImage(topLeft.X, topLeft.Y, img);
finally
img.Free;
end;
end;
procedure TManhattanSeries.GetLegendItems(AItems: TChartLegendItems);
begin
Unused(AItems); // TODO
end;
procedure TManhattanSeries.SetSeriesColor(AValue: TColor);
begin
if FSeriesColor = AValue then exit;
FSeriesColor := AValue;
UpdateParentChart;
end;
{ TConstantLine }
procedure TConstantLine.AfterAdd;
begin
inherited;
Arrow.SetOwner(ParentChart);
end;
procedure TConstantLine.Assign(ASource: TPersistent);
begin
if ASource is TConstantLine then
with TConstantLine(ASource) do begin
Self.FArrow.Assign(FArrow);
Self.FLineStyle := FLineStyle;
Self.Pen := FPen;
Self.FPosition := FPosition;
Self.FUseBounds := FUseBounds;
end;
inherited Assign(ASource);
end;
constructor TConstantLine.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FArrow := TChartArrow.Create(ParentChart);
FLineStyle := lsHorizontal;
FPen := TPen.Create;
FPen.OnChange := @StyleChanged;
FUseBounds := true;
end;
destructor TConstantLine.Destroy;
begin
FreeAndNil(FArrow);
FreeAndNil(FPen);
inherited;
end;
procedure TConstantLine.Draw(ADrawer: IChartDrawer);
var
p: Integer;
begin
if IsEmpty or (not Active) then exit;
if Pen.Style = psClear then exit;
ADrawer.SetBrushParams(bsClear, clTAColor);
ADrawer.Pen := FPen;
if FPen.Color = clDefault then
ADrawer.SetPenColor(FChart.GetDefaultColor(dctFont))
else
ADrawer.SetPenColor(FPen.Color);
with ParentChart do
case LineStyle of
lsHorizontal: begin
p := YGraphToImage(AxisToGraphX(Position));
// The "X" here is correct:
// The constant line series needs only a single axis, which is its
// "x axis" - the user will set the axis index to that of the y axis
// for the case of a horizontal line. Therefore, AxisToGraph must get
// the transformation from the line's x axis (even if it is the y axis
// of the chart!).
DrawLineHoriz(ADrawer, p);
if Arrow.Inverted then
Arrow.Draw(ADrawer, Point(ClipRect.Left, p), 0, Pen)
else
Arrow.Draw(ADrawer, Point(ClipRect.Right - 1, p), 0, Pen);
end;
lsVertical: begin
p := XGraphToImage(AxisToGraphX(Position));
DrawLineVert(ADrawer, p);
if Arrow.Inverted then
Arrow.Draw(ADrawer, Point(p, ClipRect.Bottom - 1), -Pi / 2, Pen)
else
Arrow.Draw(ADrawer, Point(p, ClipRect.Top), -Pi / 2, Pen);
end;
end;
end;
function TConstantLine.GetAxisBounds(AAxis: TChartAxis; out AMin, AMax: Double): Boolean;
begin
Result := false;
end;
function TConstantLine.GetAxisIndex: TChartAxisIndex;
begin
Result := inherited AxisIndexX;
end;
procedure TConstantLine.GetBounds(var ABounds: TDoubleRect);
begin
if not UseBounds then exit;
SavePosToCoord(ABounds.a);
SavePosToCoord(ABounds.b);
end;
procedure TConstantLine.GetLegendItems(AItems: TChartLegendItems);
begin
AItems.Add(TLegendItemLine.Create(Pen, LegendTextSingle));
end;
function TConstantLine.GetNearestPoint(
const AParams: TNearestPointParams;
out AResults: TNearestPointResults): Boolean;
begin
AResults.FIndex := -1;
AResults.FImg := AParams.FPoint;
// Return the actual nearest point of the line.
if LineStyle = lsVertical then begin
AResults.FValue.Y := FChart.YImageToGraph(AParams.FPoint.Y);
AResults.FImg.X := FChart.XGraphToImage(AxisToGraphX(Position));
end
else begin
AResults.FValue.X := FChart.XImageToGraph(AParams.FPoint.X);
AResults.FImg.Y := FChart.YGraphToImage(AxisToGraphX(Position));
end;
AResults.FDist := AParams.FDistFunc(AParams.FPoint, AResults.FImg);
Result := AResults.FDist <= Sqr(AParams.FRadius);
SavePosToCoord(AResults.FValue);
end;
function TConstantLine.GetSeriesColor: TColor;
begin
Result := FPen.Color;
end;
function TConstantLine.IsEmpty: Boolean;
begin
Result := false;
end;
procedure TConstantLine.MovePoint(
var AIndex: Integer; const ANewPos: TDoublePoint);
begin
Unused(AIndex);
Position :=
GraphToAxisX(TDoublePointBoolArr(ANewPos)[LineStyle = lsHorizontal]);
end;
procedure TConstantLine.SavePosToCoord(var APoint: TDoublePoint);
begin
TDoublePointBoolArr(APoint)[LineStyle = lsHorizontal] := Position;
end;
procedure TConstantLine.SetArrow(AValue: TChartArrow);
begin
FArrow.Assign(AValue);
UpdateParentChart;
end;
procedure TConstantLine.SetAxisIndex(AValue: TChartAxisIndex);
begin
inherited AxisIndexX := AValue;
AxisIndexY := AValue;
// Make sure that both axis indexes have the same value. The ConstantLineSeries
// does use only the x axis index, but transformations of the y axis outside
// this unit may require tha y axis index - which would not be correct without
// this here...
end;
procedure TConstantLine.SetLineStyle(AValue: TLineStyle);
begin
if FLineStyle = AValue then exit;
FLineStyle := AValue;
UpdateParentChart;
end;
procedure TConstantLine.SetPen(AValue: TPen);
begin
FPen.Assign(AValue);
end;
procedure TConstantLine.SetPosition(AValue: Double);
begin
if FPosition = AValue then exit;
FPosition := AValue;
UpdateParentChart;
end;
procedure TConstantLine.SetSeriesColor(AValue: TColor);
begin
if FPen.Color = AValue then exit;
FPen.Color := AValue;
end;
procedure TConstantLine.SetUseBounds(AValue: Boolean);
begin
if FUseBounds = AValue then exit;
FUseBounds := AValue;
UpdateParentChart;
end;
procedure TConstantLine.UpdateBiDiMode;
begin
if LineStyle = lsHorizontal then
Arrow.Inverted := not Arrow.Inverted;
end;
{ TBarSeries }
procedure TBarSeries.Assign(ASource: TPersistent);
begin
if ASource is TBarSeries then
with TBarSeries(ASource) do begin
Self.BarBrush := FBarBrush;
Self.FBarOffsetPercent := FBarOffsetPercent;
Self.BarPen := FBarPen;
Self.FBarWidthPercent := FBarWidthPercent;
Self.FBarWidthStyle := FBarWidthStyle;
Self.FOnBeforeDrawBar := FOnBeforeDrawBar;
Self.FUseZeroLevel := FUseZeroLevel;
Self.FZeroLevel := FZeroLevel;
end;
inherited Assign(ASource);
end;
procedure TBarSeries.BarOffsetWidth(
AX: Double; AIndex: Integer; out AOffset, AWidth: Double);
var
r: Double;
begin
case BarWidthStyle of
bwPercent: r := GetXRange(AX, AIndex) * PERCENT;
bwPercentMin: r := FMinXRange * PERCENT;
else
raise EBarError.Create('BarWidthStyle not implemented'){%H-};
end;
AOffset := r * BarOffsetPercent;
AWidth := r * BarWidthPercent / 2;
end;
constructor TBarSeries.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ToolTargets := [nptPoint, nptYList, nptCustom];
FDrawBarProc := @DrawRectBar;
FBarWidthPercent := DEF_BAR_WIDTH_PERCENT;
FBarBrush := TBrush.Create;
FBarBrush.OnChange := @StyleChanged;
FBarPen := TPen.Create;
FBarPen.OnChange := @StyleChanged;
FBarPen.Color := clBlack;
FBarBrush.Color := clRed;
FStacked := true;
FOptimizeX := false;
FSupportsZeroLevel := true;
FUseZeroLevel := true;
end;
destructor TBarSeries.Destroy;
begin
FreeAndNil(FBarPen);
FreeAndNil(FBarBrush);
inherited;
end;
procedure TBarSeries.Draw(ADrawer: IChartDrawer);
var
pointIndex, stackIndex: Integer;
scaled_depth: Integer;
procedure DrawBar(const AR: TRect);
var
sz: TSize;
defaultDrawing: Boolean = true;
c: TColor;
ic: IChartTCanvasDrawer;
begin
ADrawer.Pen := BarPen;
if BarPen.Color = clDefault then
ADrawer.SetPenColor(FChart.GetDefaultColor(dctFont))
else
ADrawer.SetPenColor(BarPen.Color);
ADrawer.Brush := BarBrush;
if BarBrush.Color = clDefault then
ADrawer.SetBrushColor(FChart.GetDefaultColor(dctBrush))
else
ADrawer.SetPenColor(BarPen.Color);
c := Source[pointIndex]^.Color;
if c <> clTAColor then
ADrawer.BrushColor := c;
if Styles <> nil then
Styles.Apply(ADrawer, stackIndex);
sz := Size(AR);
if (sz.cx <= 2*BarPen.Width) or (sz.cy <= 2*BarPen.Width) then begin
// Bars are too small to distinguish the border from the interior.
ADrawer.SetPenParams(psSolid, ADrawer.BrushColor);
end;
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;
FDrawBarProc(ADrawer, AR, scaled_depth);
end;
var
ext2: TDoubleRect;
w: Double;
p: TDoublePoint;
heights: TDoubleDynArray = nil;
procedure BuildBar(x, y1, y2: Double);
var
graphBar: TDoubleRect;
imageBar: TRect;
begin
graphBar := DoubleRect(x - w, y1, x + w, y2);
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 (Bottom = Top) and IsRotated then Dec(Top);
if (Left = Right) and not IsRotated then Inc(Right);
end;
DrawBar(imageBar);
end;
var
ofs, y: Double;
zero: Double;
begin
if IsEmpty or (not Active) then exit;
if BarWidthStyle = bwPercentMin then
UpdateMinXRange;
ext2 := ParentChart.CurrentExtent;
ExpandRange(ext2.a.X, ext2.b.X, 1.0);
ExpandRange(ext2.a.Y, ext2.b.Y, 1.0);
scaled_depth := ADrawer.Scale(Depth);
if UseZeroLevel then
zero := ZeroLevel
else
zero := Math.IfThen(IsRotated, ext2.a.X, ext2.a.Y);
PrepareGraphPoints(ext2, true);
SetLength(heights, Source.YCount + 1);
for pointIndex := FLoBound to FUpBound do begin
p := Source[pointIndex]^.Point;
if Source.XCount = 0 then p.X := pointIndex + FLoBound;
if SkipMissingValues(pointIndex) then
continue;
p.X := AxisToGraphX(p.X);
BarOffsetWidth(p.X, pointIndex, ofs, w);
p.X += ofs;
heights[0] := zero;
if FStacked then begin
heights[1] := NumberOr(p.Y, zero);
for stackIndex := 1 to Source.YCount - 1 do begin
y := NumberOr(Source[pointIndex]^.YList[stackIndex - 1], 0);
heights[stackIndex + 1] := heights[stackIndex] + y;
end;
for stackIndex := 0 to High(heights) do
heights[stackindex] := AxisToGraphY(heights[stackindex]);
for stackIndex := 0 to Source.YCount - 1 do
BuildBar(p.X, heights[stackindex], heights[stackIndex+1]);
end else begin
for stackIndex := 0 to Source.YCount - 1 do begin
y := Source[pointIndex]^.GetY(stackIndex);
if not IsNaN(y) then
heights[stackIndex + 1] := AxisToGraphY(y)
else
heights[stackIndex + 1] := zero;
end;
p.X -= w;
w := w / High(heights);
p.X += w;
for stackIndex := 0 to Source.YCount - 1 do begin
BuildBar(p.X, heights[0], heights[stackIndex+1]);
p.X += 2*w;
end;
end;
end;
DrawLabels(ADrawer);
end;
procedure TBarSeries.DrawConicalBar(ADrawer: IChartDrawer; const ARect: TRect;
ADepth: Integer);
var
depth2: Integer;
pts: array[0..2] of TPoint;
w, h: Integer;
a, b, factor: Double;
x1, x2, cx: Integer;
i: Integer;
c: TChartColor;
begin
if Depth = 0 then begin
pts[0] := Point(ARect.Left, ARect.Bottom);
if IsRotated then begin
pts[1] := Point(ARect.Left, ARect.Top);
pts[2] := Point(ARect.Right, (ARect.Top + ARect.Bottom) div 2);
end else begin
pts[1] := Point(ARect.Right, ARect.Bottom);
pts[2] := Point((ARect.Left + ARect.Right) div 2, ARect.Top);
end;
ADrawer.Polygon(pts, 0, 3);
exit;
end;
depth2 := ADepth div 2;
if IsRotated then begin
ADrawer.Ellipse(ARect.Left, ARect.Top, ARect.Left + ADepth, ARect.Bottom);
h := ARect.Right - ARect.Left;
if h <= depth2 then
exit;
x1 := ARect.Top;
x2 := ARect.Bottom;
end else begin
ADrawer.Ellipse(ARect.Left, ARect.Bottom, ARect.Right, ARect.Bottom - ADepth);
h := ARect.Bottom - ARect.Top;
if h <= depth2 then
exit;
x1 := ARect.Left;
x2 := ARect.Right;
end;
// Calculate the tangent points (x1, y1) of a line to an ellipse with
// half axes a, b through a point (0, h) outside the ellipse
// https://www.emathzone.com/tutorials/geometry/equation-of-tangent-and-normal-to-ellipse.html
// (x1 x) / a² + (y1 x) / b² = 1 (x, y are points on line)
// --> x1 = +/- a sqrt(1 - (b/h)²), y1 = b² / h
w := x2 - x1;
cx := (x1 + x2) div 2;
a := w * 0.5;
b := depth2;
factor := sqrt(1.0 - sqr(b / h));
pts[0] := Point(round(-a*factor), round(sqr(b) / h));
pts[1] := Point(0, h);
pts[2] := Point(round(+a*factor), pts[0].Y);
if IsRotated then
for i := 0 to 2 do
pts[i] := Point(ARect.Left + depth2 + pts[i].Y, cx - pts[i].X)
else
for i := 0 to 2 do
pts[i] := Point(cx + pts[i].X, ARect.Bottom - depth2 - pts[i].Y);
c := ADrawer.GetPenColor;
ADrawer.SetPenColor(ADrawer.BrushColor);
ADrawer.Polygon(pts, 0, 3);
ADrawer.SetPenColor(c);
ADrawer.PolyLine(pts, 0, 3);
end;
procedure TBarSeries.DrawCylinderBar(ADrawer: IChartDrawer;
const ARect: TRect; ADepth: Integer);
var
depth2: Integer;
begin
if ADepth = 0 then begin
ADrawer.Rectangle(ARect);
exit;
end;
depth2 := ADepth div 2;
if IsRotated then begin
ADrawer.Ellipse(ARect.Left, ARect.Top, ARect.Left + ADepth, ARect.Bottom);
ADrawer.FillRect(ARect.Left + depth2, ARect.Top, ARect.Right + depth2, ARect.Bottom);
ADrawer.Line(ARect.Left + depth2, ARect.Top, ARect.Right + depth2, ARect.Top);
ADrawer.Line(ARect.Left + depth2, ARect.Bottom, ARect.Right + depth2, ARect.Bottom);
ADrawer.BrushColor := GetDepthColor(ADrawer.BrushColor, false);
ADrawer.Ellipse(ARect.Right, ARect.Top, ARect.Right + ADepth, ARect.Bottom);
end else begin
ADrawer.Ellipse(ARect.Left, ARect.Bottom, ARect.Right, ARect.Bottom - ADepth);
ADrawer.FillRect(ARect.Left, ARect.Bottom - depth2, ARect.Right, ARect.Top - depth2);
ADrawer.Line(ARect.Left, ARect.Bottom - depth2, ARect.Left, ARect.Top - depth2);
ADrawer.Line(ARect.Right, ARect.Bottom - depth2, ARect.Right, ARect.Top - depth2);
ADrawer.BrushColor := GetDepthColor(ADrawer.BrushColor, true);
ADrawer.Ellipse(ARect.Left, ARect.Top, ARect.Right, ARect.Top - depth);
end;
end;
procedure TBarSeries.DrawHexPrism(ADrawer: IChartDrawer;
const ARect: TRect; ADepth: Integer);
const
HEXAGON: array[0..5] of TDoublePoint = ( { 5 4 }
(X: -1; Y: 0.5), (X: -sin(pi/6); Y: 0), (X: +sin(pi/6); Y: 0), { 0 3 }
(x: +1; Y: 0.5), (X: +sin(pi/6); Y: 1), (X: -sin(pi/6); Y: 1) { 1 2 }
);
var
a, b: double;
cx, cy: Integer;
w, h: Integer;
c: TColor;
pts: array of TPoint = nil;
i, j: Integer;
begin
if IsRotated then begin
w := ARect.Bottom - ARect.Top;
h := ARect.Right - ARect.Left;
cx := (ARect.Top + ARect.Bottom) div 2;
cy := ARect.Left;
end else begin
w := ARect.Right - ARect.Left;
h := ARect.Bottom - ARect.Top;
cx := (ARect.Left + ARect.Right) div 2;
cy := ARect.Top;
end;
a := w div 2;
b := Math.IfThen(ADepth = 0, 0, ADepth div 2);
if IsRotated then b := -b;
c := ADrawer.BrushColor;
SetLength(pts, 4);
for i:=0 to 2 do begin
ADrawer.BrushColor := c;
if (ADepth > 0) then begin
if IsRotated then begin
if i <> 1 then ADrawer.BrushColor := GetDepthColor(c, i = 0);
end else
if i <> 1 then ADrawer.BrushColor := GetDepthColor(c);
end;
pts[0] := Point(cx + round(HEXAGON[i].X * a + HEXAGON[i].Y * b), cy - round(HEXAGON[i].Y * b));
pts[1] := Point(cx + round(HEXAGON[i+1].X * a + HEXAGON[i+1].Y * b), cy - round(HEXAGON[i+1].Y * b));
pts[2] := Point(pts[1].X, pts[1].Y + h);
pts[3] := Point(pts[0].X, pts[0].Y + h);
if IsRotated then
for j := 0 to High(pts) do Exchange(pts[j].X, pts[j].Y);
ADrawer.Polygon(pts, 0, 4);
end;
if ADepth > 0 then begin
SetLength(pts, 6);
ADrawer.BrushColor := GetDepthColor(c, not IsRotated);
if IsRotated then cy := cy + h;
for i := 0 to 5 do begin
pts[i] := Point(cx + round(HEXAGON[i].X * a + HEXAGON[i].Y * b), cy - round(HEXAGON[i].Y * b));
if IsRotated then Exchange(pts[i].X, pts[i].Y);
end;
ADrawer.Polygon(pts, 0, 6);
end;
end;
procedure TBarSeries.DrawPyramidBar(ADrawer: IChartDrawer;
const ARect: TRect; ADepth: Integer);
const
PYRAMID_2D: array[0..2] of TDoublePoint = ((X:0; Y:0), (X:1; Y:0), (X:0.5; Y:1));
PYRAMID_3D: array[0..3] of TPoint = ((X:0; Y:0), (X:1; Y:0), (X:1; Y:1), (X:0; Y:1));
var
c: TColor;
pts: TPointArray = nil;
i: Integer;
depth2: Integer;
w, h: Integer;
begin
w := ARect.Right - ARect.Left;
h := ARect.Bottom - ARect.Top;
if ADepth = 0 then begin
SetLength(pts, 3);
for i := 0 to High(pts) do
pts[i] := Point(
ARect.Left + round(TDoublePointBoolArr(PYRAMID_2D[i])[IsRotated] * w),
ARect.Bottom - round(TDoublePointBoolArr(PYRAMID_2D[i])[not IsRotated] * h)
);
ADrawer.Polygon(pts, 0, 3);
exit;
end;
c := ADrawer.BrushColor;
depth2 := ADepth div 2;
SetLength(pts, 5);
if IsRotated then begin
for i := 0 to High(pts) - 1 do
pts[i] := Point(
ARect.Left + PYRAMID_3D[i].Y * ADepth,
ARect.Bottom - PYRAMID_3D[i].X * h - PYRAMID_3D[i].Y * ADepth
);
pts[High(pts)] := Point(ARect.Right + depth2, (pts[0].Y + pts[2].Y) div 2);
end else begin
for i := 0 to High(pts) - 1 do
pts[i] := Point(
ARect.Left + PYRAMID_3D[i].X * w + PYRAMID_3D[i].Y * ADepth,
ARect.Bottom - PYRAMID_3D[i].Y * ADepth
);
pts[High(pts)] := Point((pts[0].X + pts[2].X) div 2, ARect.Top - depth2);
end;
ADrawer.BrushColor := GetDepthColor(c);
ADrawer.Polygon([pts[2], pts[3], pts[4]], 0, 3);
ADrawer.Polygon([pts[3], pts[0], pts[4]], 0, 3);
ADrawer.Polygon([pts[1], pts[2], pts[4]], 0, 3);
ADrawer.BrushColor := c;
ADrawer.Polygon([pts[0], pts[1], pts[4]], 0, 3);
end;
procedure TBarSeries.DrawRectBar(ADrawer: IChartDrawer;
const ARect: TRect; ADepth: Integer);
var
c: TColor;
begin
ADrawer.Rectangle(ARect);
if ADepth > 0 then begin
c := ADrawer.BrushColor;
ADrawer.BrushColor := GetDepthColor(c, true);
ADrawer.DrawLineDepth(
ARect.Left, ARect.Top, ARect.Right - 1, ARect.Top, ADepth);
ADrawer.BrushColor := GetDepthColor(c, false);
ADrawer.DrawLineDepth(
ARect.Right - 1, ARect.Top, ARect.Right - 1, ARect.Bottom - 1, ADepth);
end;
end;
function TBarSeries.Extent: TDoubleRect;
var
x, ofs, w: Double;
i: Integer;
begin
Result := inherited Extent;
if FChart = nil then
raise EChartError.Create('Calculation of TBarSeries.Extent is not possible when the series is not added to a chart.');
if IsEmpty then exit;
if BarWidthStyle = bwPercentMin then
UpdateMinXRange;
if UseZeroLevel then
UpdateMinMax(GraphToAxisY(ZeroLevel), Result.a.Y, Result.b.Y);
// Show first and last bars fully.
if Source.XCount = 0 then begin
BarOffsetWidth(0.0, 0, ofs, w);
Result.a.X -= (ofs + w);
Result.b.X += (ofs + w);
end else begin
i := 0;
x := NearestXNumber(i, +1); // --> x is in graph units
if not IsNan(x) then begin
BarOffsetWidth(x, i, ofs, w);
x := GraphToAxisX(x + ofs - w); // x is in graph units, Extent in axis units!
Result.a.X := Min(Result.a.X, x);
end;
i := Count - 1;
x := NearestXNumber(i, -1);
if not IsNan(x) then begin
BarOffsetWidth(x, i, ofs, w);
x := GraphToAxisX(x + ofs + w);
Result.b.X := Max(Result.b.X, x);
end;
end;
end;
function TBarSeries.GetBarWidth(AIndex: Integer): Integer;
var
ofs, w: Double;
f: TGraphToImageFunc;
begin
BarOffsetWidth(GetGraphPointX(AIndex), AIndex, ofs, w);
if IsRotated then
f := @FChart.YGraphToImage
else
f := @FChart.XGraphToImage;
Result := Abs(f(2 * w) - f(0));
end;
function TBarSeries.GetLabelDataPoint(AIndex, AYIndex: Integer): TDoublePoint;
var
ofs, w, wbar: Double;
begin
Result := inherited GetLabelDataPoint(AIndex, AYIndex);
BarOffsetWidth(TDoublePointBoolArr(Result)[IsRotated], AIndex, ofs, w);
TDoublePointBoolArr(Result)[IsRotated] += ofs;
// Find x centers of bars in non-stacked bar series with multiple y values.
if (not FStacked) and (Source.YCount > 1) then begin
wbar := 2 * w / Source.YCount;
TDoublePointboolArr(Result)[IsRotated] += (wbar * (AYIndex + 0.5) - w);
end;
end;
procedure TBarSeries.GetLegendItems(AItems: TChartLegendItems);
begin
GetLegendItemsRect(AItems, BarBrush, BarPen);
end;
function TBarSeries.GetNearestPoint(const AParams: TNearestPointParams;
out AResults: TNearestPointResults): Boolean;
var
pointIndex: Integer;
graphClickPt: TDoublePoint;
sp: TDoublePoint;
ofs, w: Double;
heights: TDoubleDynArray = nil;
y: Double;
stackindex: Integer;
begin
Result := false;
AResults.FDist := Sqr(AParams.FRadius) + 1;
AResults.FIndex := -1;
AResults.FXIndex := 0;
AResults.FYIndex := 0;
if not ((nptCustom in AParams.FTargets) and (nptCustom in ToolTargets))
then begin
Result := inherited;
exit;
end;
SetLength(heights, Source.YCount + 1);
// clicked point in image units
graphClickPt := ParentChart.ImageToGraph(AParams.FPoint);
if IsRotated then
Exchange(graphclickpt.X, graphclickpt.Y);
// Iterate through all points of the series
for pointIndex := 0 to Count - 1 do begin
sp := Source[pointindex]^.Point;
if Source.XCount = 0 then
sp.X := pointIndex;
if IsNan(sp) then
continue;
sp.X := AxisToGraphX(sp.X);
BarOffsetWidth(sp.X, pointindex, ofs, w); // works with graph units
sp.X := sp.X + ofs;
if not InRange(graphClickPt.X, sp.X - w, sp.X + w) then
continue;
// Calculate stacked bar levels (in axis units)
heights[0] := ZeroLevel;
heights[1] := NumberOr(sp.Y, ZeroLevel);
for stackIndex := 1 to Source.YCount-1 do begin
y := NumberOr(Source[pointindex]^.YList[stackIndex - 1], 0);
heights[stackIndex + 1] := heights[stackindex] + y;
end;
// Convert heights to graph units
for stackIndex := 0 to High(heights) do
heights[stackIndex] := AxisToGraphY(heights[stackIndex]);
// Check if clicked pt is inside stacked bar
for stackindex := 0 to High(heights)-1 do
if ((heights[stackindex] < heights[stackindex + 1]) and
InRange(graphClickPt.Y, heights[stackindex], heights[stackIndex + 1]))
or
((heights[stackindex + 1] < heights[stackindex]) and
InRange(graphClickPt.Y, heights[stackindex + 1], heights[stackIndex]))
then begin
AResults.FDist := 0;
AResults.FIndex := pointindex;
AResults.FYIndex := stackIndex;
AResults.FValue := DoublePoint(Source[pointIndex]^.X, Source[pointindex]^.GetY(stackIndex));
if FStacked and (stackIndex > 0) then
AResults.FValue.Y := AResults.FValue.Y + heights[stackIndex];
AResults.FValue := AxisToGraph(AResults.FValue);
AResults.FImg := ParentChart.GraphToImage(AResults.FValue);
Result := true;
exit;
end;
end;
end;
function TBarSeries.GetSeriesColor: TColor;
begin
Result := FBarBrush.Color;
end;
function TBarSeries.GetZeroLevel: Double;
begin
Result := Math.IfThen(UseZeroLevel, ZeroLevel, 0.0);
end;
function TBarSeries.IsZeroLevelStored: boolean;
begin
Result := ZeroLevel <> 0.0;
end;
procedure TBarSeries.SetBarBrush(Value: TBrush);
begin
FBarBrush.Assign(Value);
end;
procedure TBarSeries.SetBarOffsetPercent(AValue: Integer);
begin
if FBarOffsetPercent = AValue then exit;
FBarOffsetPercent := AValue;
UpdateParentChart;
end;
procedure TBarSeries.SetBarPen(Value:TPen);
begin
FBarPen.Assign(Value);
end;
procedure TBarSeries.SetBarShape(AValue: TBarshape);
begin
if FBarshape = AValue then exit;
FBarShape := AValue;
case FBarShape of
bsRectangular:
FDrawBarProc := @DrawRectBar;
bsPyramid:
FDrawBarProc := @DrawPyramidBar;
bsCylindrical:
FDrawBarProc := @DrawCylinderBar;
bsConical:
FDrawBarProc := @DrawConicalBar;
bsHexPrism:
FDrawBarProc := @DrawHexPrism;
else
raise EBarError.Create('[TBarSeries.SetBarShape] No drawing procedure for bar shape.'){%H-};
end;
UpdateParentChart;
end;
procedure TBarSeries.SetBarWidthPercent(Value: Integer);
begin
if (Value < 1) or (Value > 100) then
raise EBarError.Create('Wrong BarWidth Percent');
FBarWidthPercent := Value;
UpdateParentChart;
end;
procedure TBarSeries.SetBarWidthStyle(AValue: TBarWidthStyle);
begin
if FBarWidthStyle = AValue then exit;
FBarWidthStyle := AValue;
UpdateParentChart;
end;
procedure TBarSeries.SetOnBeforeDrawBar(AValue: TBeforeDrawBarEvent);
begin
if TMethod(FOnBeforeDrawBar) = TMethod(AValue) then exit;
FOnBeforeDrawBar := AValue;
UpdateParentChart;
end;
procedure TBarSeries.SetOnCustomDrawBar(AValue: TCustomDrawBarEvent);
begin
if TMethod(FOnCustomDrawBar) = TMethod(AValue) then exit;
FOnCustomDrawBar := AValue;
UpdateParentChart;
end;
procedure TBarSeries.SetSeriesColor(AValue: TColor);
begin
FBarBrush.Color := AValue;
end;
procedure TBarSeries.SetUseZeroLevel(AValue: Boolean);
begin
if FUseZeroLevel = AValue then exit;
FUseZeroLevel := AValue;
// FSupportsZeroLevel := FUseZeroLevel;
UpdateParentChart;
end;
procedure TBarSeries.SetZeroLevel(AValue: Double);
begin
if FZeroLevel = AValue then exit;
FZeroLevel := AValue;
UpdateParentChart;
end;
procedure TBarSeries.UpdateMargins(
ADrawer: IChartDrawer; var AMargins: TRect);
const
// bsRectangular, bsCylindrical, bsHexPrism, bsPyramid, bsConical
DELTA: array[TBarShape] of TDoublePoint = (
(X:1; Y:1), (X:0; Y:1), (X:0.5; Y:0.5), (X:1; Y:0.5), (X:0; Y:0.5)
);
var
scaled_depth: Integer;
begin
inherited UpdateMargins(ADrawer, AMargins);
if FDepth <> 0 then begin
scaled_depth := ADrawer.Scale(FDepth);
if IsRotated then begin
AMargins.Right += round(DELTA[FBarShape].Y * scaled_depth);
AMargins.Top += round(DELTA[FBarShape].X * scaled_depth);
end else begin
AMargins.Right += round(DELTA[FBarShape].X * scaled_depth);
AMargins.Top += round(DELTA[FBarShape].Y * scaled_depth);
end;
end;
end;
function TBarSeries.ToolTargetDistance(const AParams: TNearestPointParams;
AGraphPt: TDoublePoint; APointIdx, AXIdx, AYIdx: Integer): Integer;
var
sp1, sp2: TDoublePoint;
clickPt, pt1, pt2: TPoint;
ofs, w: Double;
dist1, dist2: Integer;
begin
Unused(APointIdx);
Unused(AXIdx, AYIdx);
clickPt := AParams.FPoint;
if IsRotated then begin
Exchange(clickPt.X, clickPt.Y);
Exchange(AGraphPt.X, AGraphPt.Y);
end;
BarOffsetWidth(AGraphPt.X, APointIdx, ofs, w);
sp1 := DoublePoint(AGraphPt.X + ofs - w, AGraphPt.Y);
sp2 := DoublePoint(AGraphPt.X + ofs + w, AGraphPt.Y);
if IsRotated then begin
Exchange(sp1.X, sp1.Y);
Exchange(sp2.X, sp2.Y);
end;
pt1 := ParentChart.GraphToImage(sp1);
pt2 := ParentChart.GraphToImage(sp2);
if IsRotated then begin
Exchange(pt1.X, pt1.Y);
Exchange(pt2.X, pt2.Y);
if pt1.X > pt2.X then Exchange(pt1.X, pt2.X);
end;
if InRange(clickPt.X, pt1.X, pt2.X) then
Result := sqr(clickPt.Y - pt1.Y)
else begin
dist1 := AParams.FDistFunc(clickPt, pt1);
dist2 := AParams.FDistFunc(clickPt, pt2);
Result := Min(dist1, dist2);
end;
end;
{ TAreaSeries }
procedure TAreaSeries.Assign(ASource: TPersistent);
begin
if ASource is TAreaSeries then
with TAreaSeries(ASource) do begin
Self.AreaBrush := FAreaBrush;
Self.AreaContourPen := FAreaContourPen;
Self.AreaLinesPen := FAreaLinesPen;
Self.FConnectType := FConnectType;
Self.FUseZeroLevel := FUseZeroLevel;
Self.FZeroLevel := FZeroLevel;
end;
inherited Assign(ASource);
end;
constructor TAreaSeries.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAreaBrush := TBrush.Create;
FAreaBrush.OnChange := @StyleChanged;
FAreaContourPen := TPen.Create;
FAreaContourPen.OnChange := @StyleChanged;
FAreaLinesPen := TPen.Create;
FAreaLinesPen.OnChange := @StyleChanged;
FStacked := true;
FSupportsZeroLevel := true; //FUseZeroLevel;
end;
destructor TAreaSeries.Destroy;
begin
FreeAndNil(FAreaBrush);
FreeAndNil(FAreaContourPen);
FreeAndNil(FAreaLinesPen);
inherited;
end;
procedure TAreaSeries.Draw(ADrawer: IChartDrawer);
var
pts: TPointArray = nil;
basePts: TPointArray = nil;
numPts, numBasePts: Integer;
scaled_depth: Integer;
missing: array of Integer = nil;
numMissing: Integer;
zero: Double;
ext, ext2: TDoubleRect;
{ Replaces y=NaN at first level by zero if StackedNaN is ReplaceByZero }
procedure FixNaN;
var
i: Integer;
begin
if FStackedNaN = snReplaceByZero then
for i := 0 to High(FGraphPoints) do
if IsNaN(FGraphPoints[i].Y) then FGraphPoints[i].Y := 0.0;
end;
procedure CollectMissingItem(AIndex: Integer);
begin
missing[numMissing] := AIndex;
inc(numMissing);
end;
{ Collects the indexes of data points having NaN as x or any of the y values }
procedure CollectMissing;
var
i, j: Integer;
item: PChartDataItem;
begin
SetLength(missing, Length(FGraphPoints));
numMissing := 0;
for i := 0 to High(FGraphPoints) do begin
item := Source.Item[i + FLoBound];
if IsNaN(item^.X) then
CollectMissingItem(i)
else
if IsNaN(item^.Y) and ((FStackedNaN = snDoNotDraw) or FBanded) then
CollectMissingItem(i)
else
if FStacked and (FStackedNaN = snDoNotDraw) then
for j := 0 to Source.YCount - 2 do
if IsNaN(item^.YList[j]) then CollectMissingItem(i);
end;
SetLength(missing, numMissing);
end;
procedure PushPoint(const AP: TPoint); overload;
begin
if (numPts > 0) and (AP = pts[numPts - 1]) then exit;
pts[numPts] := AP;
numPts += 1;
end;
procedure PushPoint(const AP: TDoublePoint); overload;
begin
PushPoint(ParentChart.GraphToImage(AP));
end;
procedure PushBasePoint(AP: TDoublePoint; AIndex: Integer);
var
p: TPoint;
begin
p := ParentChart.GraphToImage(AP);
if IsRotated then
p.X := basePts[Math.IfThen(FBanded, AIndex, 1)].X
else
p.Y := basePts[Math.IfThen(FBanded, AIndex, 1)].Y;
PushPoint(p);
end;
function ProjToLine(const APt: TDoublePoint; ACoord: Double): TDoublePoint;
begin
Result := APt;
if IsRotated then
Result.X := ACoord
else
Result.Y := ACoord;
end;
// Widens zero-width area to see at least a narrow stripe.
procedure FixZeroWidth;
var
p1, p2, p3: TPoint;
delta: Integer;
begin
delta := ADrawer.Scale(1);
if numPts = 1 then begin
p1 := pts[0];
if IsRotated then begin
dec(pts[0].Y, delta);
inc(p1.Y, delta);
end else begin
dec(pts[0].X, delta);
inc(p1.X, delta);
end;
PushPoint(p1);
end else
if numPts = 2 then begin
p1 := pts[numpts-1];
p2 := pts[numpts-2];
if IsRotated and (p1.Y = p2.Y) then begin
pts[0] := p1;
pts[1] := p2;
inc(p1.Y, 2*delta);
inc(p2.Y, 2*delta);
PushPoint(p2);
PushPoint(p1);
end else
if not IsRotated and (p1.X = p2.X) then begin
pts[0] := p1;
pts[1] := p2;
inc(p1.X, 2*delta);
inc(p2.X, 2*delta);
PushPoint(p2);
PushPoint(p1);
end;
end else
if numPts > 2 then begin
p1 := pts[numpts-1];
p2 := pts[numpts-2];
p3 := pts[numpts-3];
if IsRotated and (p1.Y = p2.Y) and (p2.Y = p3.Y) then begin
dec(pts[numpts-3].Y, delta);
dec(pts[numpts-2].Y, delta);
inc(pts[numpts-1].Y, delta);
pts[numpts-1].X := p2.X;
inc(p3.Y, delta);
PushPoint(p3);
end else
if not IsRotated and (p1.X = p2.X) and (p2.X = p3.X) then begin
dec(pts[numpts-3].X, delta);
dec(pts[numpts-2].X, delta);
inc(pts[numpts-1].X, delta);
pts[numpts-1].Y := p2.Y;
inc(p3.X, delta);
PushPoint(p3);
end;
end;
end;
procedure CollectPoints(AStart, AEnd: Integer);
var
i: Integer;
a, b: TDoublePoint;
singlePoint: Boolean;
begin
singlepoint := AStart = AEnd;
if singlepoint then inc(AEnd);
for i := AStart to AEnd - 1 do begin
a := FGraphPoints[i];
if singlePoint then b := a else b := FGraphPoints[i + 1];
case ConnectType of
ctLine: ;
ctStepXY:
if IsRotated then
b.X := a.X
else
b.Y := a.Y;
ctStepYX:
if IsRotated then
a.X := b.X
else
a.Y := b.Y;
end;
if IsNaN(a) and IsNaN(b) then begin
PushBasePoint(a, i);
if i < AEnd then PushBasePoint(b, i+1) else PushBasePoint(b, i);
end else
if IsNaN(b) then begin
PushPoint(a);
PushBasePoint(a, i);
FixZeroWidth;
if i < AEnd then PushBasePoint(b, i+1) else PushBasePoint(b, i);
end else
if IsNaN(a) then begin
PushBasepoint(a, i);
FixZeroWidth;
if i < AEnd then PushBasePoint(b, i+1) else PushBasePoint(b, i);
PushPoint(b);
end else begin
PushPoint(a);
PushPoint(b);
end;
end;
FixZeroWidth;
end;
procedure CopyPoints(var ADest: TPointArray; ASource: TPointArray;
ANumPts: Integer);
var
i: Integer;
begin
for i:=0 to ANumPts - 1 do
ADest[i] := ASource[i];
end;
procedure DrawSegment(AStart, AEnd: Integer);
var
numDataPts: Integer;
p: TDoublePoint;
i, j, j0: Integer;
zeroPt: TPoint;
c: TColor;
begin
// Get baseline of area series: this is the curve of the 1st y value in case
// of banded, or the zero level in case for normal area series.
if FBanded then begin
UpdateGraphPoints(-1, FLoBound, FUpBound, FStacked);
numPts := 0;
CollectPoints(AStart, AEnd);
numBasePts := numPts;
end else begin
numPts := 0;
p := ProjToRect(FGraphPoints[AStart], ext2);
PushPoint(ProjToLine(p, zero));
p := ProjToRect(FGraphPoints[AEnd], ext2);
PushPoint(ProjToLine(p, zero));
FixZeroWidth;
numBasePts := numPts;
end;
SetLength(basePts, numBasePts);
CopyPoints(basePts, pts, numBasePts);
// Iterate through y values
j0 := Math.IfThen(FBanded and (Source.YCount > 1), 0, -1);
for j := Source.YCount - 2 downto j0 do begin
// Stack level points
numPts := 0;
UpdateGraphPoints(j, FLoBound, FUpBound, FStacked);
CollectPoints(AStart, AEnd);
numDataPts := numPts;
// Base points
for i:=numBasePts-1 downto 0 do
PushPoint(basepts[i]);
// Prepare painting
ADrawer.Brush := AreaBrush;
if AreaBrush.Color = clDefault then
ADrawer.SetBrushColor(FChart.GetDefaultColor(dctBrush))
else
ADrawer.SetBrushColor(AreaBrush.Color);
ADrawer.Pen := AreaContourPen;
if AreaContourPen.Color = clDefault then
ADrawer.SetPenColor(FChart.GetDefaultColor(dctFont))
else
ADrawer.SetPenColor(AreaContourPen.Color);
if Styles <> nil then
Styles.Apply(ADrawer, j - j0);
// Draw 3D sides
// Note: Rendering is often incorrect, e.g. when values cross zero level
// or when values are not stacked!
if (Depth > 0) then begin
c := ADrawer.BrushColor;
ADrawer.BrushColor := GetDepthColor(c);
// Top sides
if (Source.YCount = 1) or (not FStacked) or (j = Source.YCount-2) then
for i := 0 to numDataPts-2 do
ADrawer.DrawLineDepth(pts[i], pts[i+1], scaled_depth);
// Sides at the right
ADrawer.DrawLineDepth(pts[numdataPts-1], pts[numDataPts], scaled_depth);
ADrawer.BrushColor := c;
end;
// Fill polygon of current level
ADrawer.Polygon(pts, 0, numPts);
// Draw drop-lines
if AreaLinesPen.Style <> psClear then begin
if FBanded and (j > -1) then begin
ADrawer.Pen := AreaLinesPen;
if AreaLinesPen.Color = clDefault then
ADrawer.SetPenColor(FChart.GetDefaultColor(dctFont))
else
ADrawer.SetPenColor(AreaLinesPen.Color);
for i := 1 to numDataPts-2 do
ADrawer.Line(pts[i], pts[numpts - 1 - i]);
end else
if not FBanded then begin
ADrawer.Pen := AreaLinesPen;
if AreaLinesPen.Color = clDefault then
ADrawer.SetPenColor(FChart.GetDefaultColor(dctFont))
else
ADrawer.SetPenColor(AreaLinesPen.Color);
zeroPt := pts[numDataPts];
for i := 1 to numDataPts-2 do begin
if IsRotated then zeroPt.Y := pts[i].Y else zeroPt.X := pts[i].X;
ADrawer.Line(pts[i], zeroPt);
end;
end;
end;
end;
end;
var
j, k: Integer;
begin
if IsEmpty or (not Active) then exit;
ext := ParentChart.CurrentExtent;
ext2 := ext;
ExpandRange(ext2.a.X, ext2.b.X, 0.1);
ExpandRange(ext2.a.Y, ext2.b.Y, 0.1);
PrepareGraphPoints(ext, true);
if Length(FGraphPoints) = 0 then
exit;
FixNaN;
if UseZeroLevel then
zero := AxisToGraphY(ZeroLevel)
else
zero := Math.IfThen(IsRotated, ext2.a.X, ext2.a.Y);
scaled_depth := ADrawer.Scale(Depth);
SetLength(pts, Length(FGraphPoints) * 4 + 4);
CollectMissing;
if Length(missing) = 0 then
DrawSegment(0, High(FGraphPoints))
else begin
j := 0;
k := 0;
while j < Length(missing) do begin
while (missing[j] = k) do begin
inc(k);
inc(j);
if j = Length(missing) then
break;
end;
if j <= High(missing) then begin
DrawSegment(k, missing[j]-1);
k := missing[j]+1;
end else
DrawSegment(k, High(FGraphPoints));
inc(j);
end;
if k <= High(FGraphPoints) then
DrawSegment(k, High(FGraphPoints));
end;
DrawLabels(ADrawer);
end;
function TAreaSeries.Extent: TDoubleRect;
begin
Result := inherited Extent;
if not IsEmpty and UseZeroLevel then
UpdateMinMax(GraphToAxisY(ZeroLevel), Result.a.Y, Result.b.Y);
end;
procedure TAreaSeries.GetLegendItems(AItems: TChartLegendItems);
begin
GetLegendItemsRect(AItems, AreaBrush, AreaContourPen);
end;
function TAreaSeries.GetSeriesColor: TColor;
begin
Result := FAreaBrush.Color;
end;
function TAreaSeries.GetZeroLevel: Double;
begin
Result := Math.IfThen(UseZeroLevel, ZeroLevel, 0.0);
end;
function TAreaSeries.IsZeroLevelStored: boolean;
begin
Result := ZeroLevel <> 0.0;
end;
procedure TAreaSeries.SetAreaBrush(AValue: TBrush);
begin
FAreaBrush.Assign(AValue);
UpdateParentChart;
end;
procedure TAreaSeries.SetAreaContourPen(AValue: TPen);
begin
FAreaContourPen.Assign(AValue);
UpdateParentChart;
end;
procedure TAreaSeries.SetAreaLinesPen(AValue: TPen);
begin
FAreaLinesPen.Assign(AValue);
UpdateParentChart;
end;
procedure TAreaSeries.SetBanded(AValue: Boolean);
begin
if FBanded = AValue then exit;
FBanded := AValue;
UpdateParentChart;
end;
procedure TAreaSeries.SetConnectType(AValue: TConnectType);
begin
if FConnectType = AValue then exit;
FConnectType := AValue;
UpdateParentChart;
end;
procedure TAreaSeries.SetSeriesColor(AValue: TColor);
begin
FAreaBrush.Color := AValue;
end;
procedure TAreaSeries.SetUseZeroLevel(AValue: Boolean);
begin
if FUseZeroLevel = AValue then exit;
FUseZeroLevel := AValue;
// FSupportsZeroLevel := FUseZeroLevel;
UpdateParentChart;
end;
procedure TAreaSeries.SetZeroLevel(AValue: Double);
begin
if FZeroLevel = AValue then exit;
FZeroLevel := AValue;
UpdateParentChart;
end;
function TAreaSeries.SkipMissingValues(AIndex: Integer): Boolean;
begin
Result := inherited;
if not Result then
Result := FBanded and IsNaN(Source.Item[AIndex]^.Y);
end;
{ TUserDrawnSeries }
procedure TUserDrawnSeries.Assign(ASource: TPersistent);
begin
if ASource is TUserDrawnSeries then
with TUserDrawnSeries(ASource) do begin
Self.FOnDraw := FOnDraw;
Self.FOnGetBounds := FOnGetBounds;
end;
inherited Assign(ASource);
end;
procedure TUserDrawnSeries.Draw(ADrawer: IChartDrawer);
var
ic: IChartTCanvasDrawer;
begin
if IsEmpty or (not Active) then exit;
if Supports(ADrawer, IChartTCanvasDrawer, ic) and Assigned(FOnDraw) then
FOnDraw(ic.Canvas, FChart.ClipRect);
end;
procedure TUserDrawnSeries.GetBounds(var ABounds: TDoubleRect);
begin
if Assigned(FOnGetBounds) then
FOnGetBounds(ABounds);
end;
procedure TUserDrawnSeries.GetLegendItems(AItems: TChartLegendItems);
begin
Unused(AItems);
end;
function TUserDrawnSeries.IsEmpty: Boolean;
begin
Result := not Assigned(FOnDraw);
end;
procedure TUserDrawnSeries.SetOnDraw(AValue: TSeriesDrawEvent);
begin
if TMethod(FOnDraw) = TMethod(AValue) then exit;
FOnDraw := AValue;
UpdateParentChart;
end;
procedure TUserDrawnSeries.SetOnGetBounds(AValue: TSeriesGetBoundsEvent);
begin
if TMethod(FOnGetBounds) = TMethod(AValue) then exit;
FOnGetBounds := AValue;
UpdateParentChart;
end;
procedure SkipObsoleteProperties;
const
STAIRS_NOTE = 'Obsolete, use ConnectType instead';
DRAWPOINTER_NOTE = 'Obsolete, use OnCustomDrawPointer instead';
begin
RegisterPropertyEditor(
TypeInfo(TChartAxisIndex), TConstantLine, 'AxisIndexX', THiddenPropertyEditor);
RegisterPropertyToSkip(TAreaSeries, 'Stairs', STAIRS_NOTE, '');
RegisterPropertyToSkip(TAreaSeries, 'InvertedStairs', STAIRS_NOTE, '');
RegisterPropertyToSkip(TLineSeries, 'OnDrawPointer', DRAWPOINTER_NOTE, '');
end;
initialization
RegisterSeriesClass(TLineSeries, @rsLineSeries);
RegisterSeriesClass(TAreaSeries, @rsAreaSeries);
RegisterSeriesClass(TBarSeries, @rsBarSeries);
RegisterSeriesClass(TPieSeries, @rsPieSeries);
RegisterSeriesClass(TUserDrawnSeries, @rsUserDrawnSeries);
RegisterSeriesClass(TConstantLine, @rsConstantLine);
RegisterSeriesClass(TManhattanSeries, @rsManhattanPlotSeries);
// {$WARNINGS OFF}RegisterSeriesClass(TLine, nil);{$WARNINGS ON}
SkipObsoleteProperties;
end.
Reference in New Issue View Git Blame Copy Permalink