diff --git a/Graphics/JPL.RoseDiag.BinDataList.pas b/Graphics/JPL.RoseDiag.BinDataList.pas new file mode 100644 index 0000000..1307239 --- /dev/null +++ b/Graphics/JPL.RoseDiag.BinDataList.pas @@ -0,0 +1,794 @@ +unit JPL.RoseDiag.BinDataList; + +{ + Jacek Pazera + https://www.pazera-software.com + https://github.com/jackdp + + License: public domain. + + + BIN = numerical (angular) range + + + 2022.06 +} + +{$I .\..\jp.inc} + +{$IFDEF FPC} + {$mode delphi}{$H+} +{$ENDIF} + +interface + +uses + Classes, SysUtils, Graphics, Dialogs, Math, + Generics.Collections, + JPL.Strings, JPL.TStr, JPL.Conversion, JPL.Math; + +type + +{$IFDEF DCC} + Float = Extended; +{$ENDIF} + + + // What to do with linear measurements when the measurement value is not between 0-180 degrees? + // lmfmNormalize - 180 degrees will be added or subtracted to the measurement value until the value is within 0-180 degrees. + // lmfmRemove - The value will be removed from the measurement list. + TLinearMeasurementFixMode = (lmfmNormalize, lmfmRemove); + + TBinStats = record + BinCount: Word; + MeasurementCount: Word; // Total number of valid measurements + SumOfMeasurements: Double; // Sum of all measurements + MeasurementsPerBin: Single; // Average number of measurements in the bin + MaxMeasurementsInBin: Word; // Maximum number of measurements in the bin(s) + MinMeasurementsInBin: Word; // Minimum number of measurements in the bin(s) + BinsWithMaxMeasurements: Word; // The number of bins with the maximum number of measurements + BinsWithMinMeasurements: Word; // The number of bins with the minimum number of measurements + MaxMeasurementsInBin_Percentage: Single; + Mean: Float; // Average measurement + StdDev: Float; // Standard deviation + procedure Clear; + end; + + TMeasurementArray = array of Single; + + TBinData = record + No: integer; // Bin number (the first No = 1) + BinIndex: integer; // Bin index (the first index = 0) + Percent: Single; // Number of measurements in the bin relative to the total number of measurements, expressed as a percentage + Values: TMeasurementArray; // Array with all values belonging to the given bin + StartValue: Word; // The starting value of the bin (the starting angle in degrees) + EndValue: Word; // End value of the bin (end angle in degrees) + Selected: Boolean; // Used when drawing the diagram + function MeasurementCount: Word; // The number of measurements in a bin. The WORD type should be fine. + function SumOfMeasurements: Double; // Sum of all measurements in a bin + function AsString(Separator: string = ' '): string; // for debug purposes + function Mean: Float; + function StdDev: Float; + function ValuesAsStr(Separator: string = '; '): string; + procedure Clear; + end; + + TCustomBinDataList = TList; + + TBinDataList = class(TCustomBinDataList) + private + FAutoUpdateBins: Boolean; + FAzimuths: Boolean; + FLinearMeasurementFixMode: TLinearMeasurementFixMode; + FClassSize: Byte; + FMeasurements: TMeasurementArray; + FStats: TBinStats; + function GetSelectedBinsCount: integer; + procedure SetAzimuths(AValue: Boolean); + procedure SetClassSize(AValue: Byte); + procedure SetLinearMeasurementFixMode(AValue: TLinearMeasurementFixMode); + public + constructor Create(const AClassSize: Byte = 10); + procedure ClearParams(ClearMeasurements: Boolean = False); + function AsDebugStr: string; + + // Tworzy listę przedziałów (bins) i przyporządkowuje do nich pomiary (wywołuje ProcessMeasurementArray(FMeasurements)). + procedure UpdateBins; + + ///////////////// The main procedure ////////////////////// + // It assigns measurements to appropriate bins and calculates some additional parameters (MaxCount, MinCount...) + procedure ProcessMeasurementArray(const Arr: TMeasurementArray); overload; + procedure ProcessMeasurementArray(const Arr: array of Single); overload; + /////////////////////////////////////////////////////////////////////// + + procedure ProcessText(const Text: string); // Process (multi-line) text with meausurements. One measurement per line. + + procedure GetMeasurementArray(var Arr: TMeasurementArray); // Saves all measurements to the given array + + // Generates the given number of random measurements from the given range + procedure GenerateRandomData(const Count: Word; MinValue: Word = 0; MaxValue: Word = 360; FloatValues: Boolean = False); + + procedure SelectBin(const BinIndex: integer); + procedure SelectBins(const NumberOfMeasurements: Word); // Select all bins with the given number of measurements + procedure SelectMaxBins; // Select all bins with the maximum number of measurements + procedure SelectMinBins; // Select all bins with the minimum number of measurements + procedure SelectAllBins; + procedure UnselectAllBins; + procedure InvertSelectedBins; + + // Calculate various statistical data and save in the Stats record. + // Automatically called when processing an array with measurements. + procedure CalculateStats; + + property ClassSize: Byte read FClassSize write SetClassSize; // Must be an integer divisor of 360 (or 90?) + property SelectedBinsCount: integer read GetSelectedBinsCount; // The number of bins marked as selected + property Stats: TBinStats read FStats; + property Azimuths: Boolean read FAzimuths write SetAzimuths; // Measurements in range 0-360 + + // See description of the TLinearMeasurementFixMode above + property LinearMeasurementFixMode: TLinearMeasurementFixMode read FLinearMeasurementFixMode write SetLinearMeasurementFixMode; + + // Not modified list of measurements + // Przy przetwarzaniu pomiarów, niektóre z nich mogą nie trafić do "binów", gdy Azimuths=False i LinearMeasurementFixMode=lmfmRemove. + // Tablica Measurements zawiera wszystkie pomiary, także te nieprawidłowe. + property Measurements: TMeasurementArray read FMeasurements; + + // Decyduje, czy przy zmianie niektórych parametrów (np. ClassSize), lista przedziałów będzie odtwarzana automatycznie. + property AutoUpdateBins: Boolean read FAutoUpdateBins write FAutoUpdateBins; + end; + + +{$region ' helpers '} +function LinearMeasurementFixModeToStrID(const FixMode: TLinearMeasurementFixMode): string; +function StrIDToLinearMeasurementFixMode(StrID: string; Default: TLinearMeasurementFixMode = lmfmNormalize): TLinearMeasurementFixMode; +function MeasurementArrayAsText(const Arr: TMeasurementArray): string; +procedure SaveMeasurementArrayAsTextFile(const Arr: TMeasurementArray; const FileName: string); +procedure CopyMeasurementArray(const Src: array of Single; var Dest: TMeasurementArray); +procedure FixLinearMeasurements(var Arr: TMeasurementArray; const FixMode: TLinearMeasurementFixMode); +procedure GetSymmetricalData(const Arr: TMeasurementArray; var ArrSymm: TMeasurementArray); +function IsValidClassSize(const x: integer): Boolean; +procedure FillMeasurementArrayWithRandomValues(var Arr: TMeasurementArray; Count: Word; MinValue: Word = 0; MaxValue: Word = 360; FloatValues: Boolean = False); +{$endregion helpers} + + +implementation + +uses + JPL.RoseDiag.Diagram; + + +{$region ' helpers '} + +function LinearMeasurementFixModeToStrID(const FixMode: TLinearMeasurementFixMode): string; +begin + if FixMode = lmfmNormalize then Result := 'normalize_180' else Result := 'remove'; +end; + +function StrIDToLinearMeasurementFixMode(StrID: string; Default: TLinearMeasurementFixMode = lmfmNormalize): TLinearMeasurementFixMode; +begin + StrID := TStr.TrimAndLow(StrID); + if StrID = 'normalize_180' then Result := lmfmNormalize + else if StrID = 'remove' then Result := lmfmRemove + else Result := Default; +end; + +function MeasurementArrayAsText(const Arr: TMeasurementArray): string; +var + s: string; + i: integer; +begin + s := ''; + for i := 0 to High(Arr) do + begin + s := s + ftos(Arr[i], 2) + ENDL; + end; + Result := Trim(s); +end; + +procedure SaveMeasurementArrayAsTextFile(const Arr: TMeasurementArray; const FileName: string); +var + s: string; +begin + s := MeasurementArrayAsText(Arr); + SaveStringToFile(FileName, s); +end; + +procedure CopyMeasurementArray(const Src: array of Single; var Dest: TMeasurementArray); +var + i: integer; +begin + SetLength(Dest, Length(Src)); + for i := 0 to High(Src) do Dest[i] := Src[i]; +end; + +procedure FixLinearMeasurements(var Arr: TMeasurementArray; const FixMode: TLinearMeasurementFixMode); +var + i: integer; + ArrFix: TMeasurementArray; + xValue: Single; +begin + SetLength(ArrFix{%H-}, 0); + + for i := 0 to High(Arr) do + begin + xValue := Arr[i]; + + if xValue < 0 then + begin + if FixMode = lmfmRemove then Continue; + while xValue < 0 do xValue := xValue + 180; + end + + else if xValue > 180 then + begin + if FixMode = lmfmRemove then Continue; + while xValue > 180 do xValue := xValue - 180; + end; + + SetLength(ArrFix, Length(ArrFix) + 1); + ArrFix[High(ArrFix)] := xValue; + end; + + + Arr := ArrFix; +end; + +procedure GetSymmetricalData(const Arr: TMeasurementArray; var ArrSymm: TMeasurementArray); +var + i, dx: integer; + xVal1, xVal2: Single; +begin + SetLength(ArrSymm, Length(Arr) * 2); + dx := 0; + + for i := 0 to High(Arr) do + begin + xVal1 := Arr[i]; + + if xVal1 >= 180 then xVal2 := xVal1 - 180 + else xVal2 := xVal1 + 180; + + ArrSymm[i + dx] := xVal1; + ArrSymm[i + dx + 1] := xVal2; + Inc(dx); + end; +end; + +function IsValidClassSize(const x: integer): Boolean; +begin + if (x <= 0) or (x > 180) then Exit(False); + Result := 360 {90} mod x = 0; +end; + +procedure FillMeasurementArrayWithRandomValues(var Arr: TMeasurementArray; Count: Word; MinValue: Word = 0; MaxValue: Word = 360; FloatValues: Boolean = False); +var + i: integer; +begin + SetLength(Arr, 0); + if Count <= 0 then Exit; + if MaxValue < MinValue then Exit; + + SetLength(Arr, Count); + Randomize; + + if FloatValues then + begin + for i := 0 to Count - 1 do + begin + Arr[i] := RandomInt(MinValue, MaxValue, 0) + Random; + if Arr[i] > MaxValue then Arr[i] := Arr[i] - 1; + end; + end + else + for i := 0 to Count - 1 do Arr[i] := RandomInt(MinValue, MaxValue, 0); +end; + +{$endregion helpers} + + + + +{$region ' TBinDataList '} + +constructor TBinDataList.Create(const AClassSize: Byte); +begin + inherited Create; + FClassSize := AClassSize; + FAzimuths := True; + LinearMeasurementFixMode := lmfmNormalize; + FAutoUpdateBins := True; + ClearParams; +end; + +procedure TBinDataList.ClearParams(ClearMeasurements: Boolean); +begin + Clear; + FStats.Clear; + if ClearMeasurements then SetLength(FMeasurements, 0); +end; + +procedure TBinDataList.SetClassSize(AValue: Byte); +begin + if FClassSize = AValue then Exit; + if not IsValidClassSize(AValue) then AValue := RD_DEFAULT_CLASS_SIZE; + FClassSize := AValue; + if FAutoUpdateBins then UpdateBins; +end; + +procedure TBinDataList.SetLinearMeasurementFixMode(AValue: TLinearMeasurementFixMode); +begin + if FLinearMeasurementFixMode = AValue then Exit; + FLinearMeasurementFixMode := AValue; + if FAutoUpdateBins then UpdateBins; +end; + +procedure TBinDataList.SetAzimuths(AValue: Boolean); +begin + if FAzimuths = AValue then Exit; + FAzimuths := AValue; + if FAutoUpdateBins then UpdateBins; +end; + +function TBinDataList.GetSelectedBinsCount: integer; +var + BinData: TBinData; +begin + Result := 0; + for BinData in Self do + if BinData.Selected then Inc(Result); +end; + + {$region ' ProcessMeasurementArray '} +procedure TBinDataList.ProcessMeasurementArray(const Arr: TMeasurementArray); +var + i, k: integer; + BinCount: SmallInt; + Measurement: Single; + BinData: TBinData; + b180, bInRange: Boolean; + ArrM: TMeasurementArray; +begin + ClearParams; + FMeasurements := Arr; + + if ClassSize = 0 then Exit; // must be greather than 0 + b180 := not FAzimuths; + + + ArrM := Arr; + if b180 then FixLinearMeasurements(ArrM, FLinearMeasurementFixMode); + + //SaveMeasurementArrayAsTextFile(ArrM, 'ArrM.txt'); + + + + // ----------- EN ----------- + // BinCount - number of ranges. + // I am using an angular scale in degrees. Sometimes you can also find rose diagrams graduated in grads. + // The grad scale, although more accurate, is usually only used in geodesy, so I'll stick to the degrees. + + + // ----------- PL ----------- + // BinCount - liczba przedziałów. + // Stosuję skalę kątową w stopniach. Niekiedy można też spotkać diagramy rozetowe wyskalowane w gradach. + // Skala gradowa, chociaż dokładniejsza, stosowana jest raczej tylko w geodezji, więc będę się trzymał stopni. + + if b180 then BinCount := 180 div ClassSize + else BinCount := 360 div ClassSize; + + + // ----------- EN ----------- + // BIN - numerical (angular) range + // In English literature and programs, the term "BIN" is usually used here when drawing rose diagrams. + + // BinData represents the angular range. + // BinData.MeasurementCount - number of measurements belonging to the given range. + // BinData.StartValue and BinData.EndValue - start and end of an angular range. + // All ranges, except the 1st, are left open and right closed. + // The first range is left closed (0 belongs to the 1st range). + // BinData.Values - array of all measurements belonging to a given range. + + + // ----------- PL ----------- + // BIN - przedział liczbowy (kątowy). + // W literaturze i programach angielskojęzycznych, przy kreśleniu diagramów rozetowych z reguły stosuje się tutaj termin "BIN". + + // BinData reprezentuje przedział kątowy. + // BinData.MeasurementCount - liczba azymutów należących do danego przedziału. + // BinData.StartValue i BinData.EndValue - początek i koniec przedziału kątowego. + // Wszystkie przedziały, oprócz 1-szego, są lewostronnie otwarte i prawostronnie domknięte. + // Przedział pierwszy jest lewostronnie domknięty (0 jest zaliczane do 1-szego przedziału). + // BinData.Values - tablica wszystkich azymutów należących do danego przedziału. + + for i := 0 to BinCount - 1 do + begin + BinData.No := i + 1; + BinData.Percent := 0; + BinData.BinIndex := i; + BinData.Selected := False; + BinData.StartValue := (i * ClassSize); + BinData.EndValue := (i + 1) * ClassSize; + SetLength(BinData.Values, 0); + + for k := 0 to High(ArrM) do + begin + Measurement := ArrM[k]; + + if Measurement = 0 then bInRange := BinData.BinIndex = 0 + else bInRange := ( (Measurement > BinData.StartValue) and (Measurement <= BinData.EndValue) ); + + if bInRange then + begin + SetLength(BinData.Values, Length(BinData.Values) + 1); + BinData.Values[High(BinData.Values)] := Measurement; + end; + end; + Self.Add(BinData); + end; // for i + + CalculateStats; +end; + +procedure TBinDataList.ProcessMeasurementArray(const Arr: array of Single); +var + AA: TMeasurementArray; + i: integer; +begin + SetLength(AA{%H-}, Length(Arr)); + for i := 0 to High(Arr) do + AA[i] := Arr[i]; + ProcessMeasurementArray(AA); +end; + + {$endregion ProcessMeasurementArray} + + {$region ' ProcessText '} +procedure TBinDataList.ProcessText(const Text: string); +var + AR: TMeasurementArray; + sl: TStringList; + i, x: integer; + Line, sNum: string; + znak: Char; + xd: Double; +begin + sl := TStringList.Create; + try + + sl.Text := Text; + + for i := sl.Count - 1 downto 0 do + begin + + Line := sl[i]; + Line := Trim(Line); + + // Removing empty lines and comments + {$B-} + if (Line = '') or (Line[1] = ';') or (Line[1] = '#') or (Copy(Line, 1, 2) = '//') then + begin + sl.Delete(i); + Continue; + end; + + // Attempt to read a number at the beginning of the line + // The sign that separates the whole part from the fractional part can be a point or a comma + sNum := ''; + for x := 1 to Length(Line) do + begin + znak := Line[x]; + if (znak <> '.') and (znak <> ',') and (not IsNumber(znak)) then Break + else sNum := sNum + znak; + end; + + // If the value read is not a number, the line is removed + if (sNum = '') or (not TryStoF(sNum, xd{%H-})) then + begin + sl.Delete(i); + Continue; + end; + + sl[i] := sNum; + + end; // for i + + + SetLength(AR{%H-}, sl.Count); + for i := 0 to sl.Count - 1 do AR[i] := stof(sl[i]); + + + ProcessMeasurementArray(AR); + + + finally + sl.Free; + end; +end; + {$endregion ProcessText} + +procedure TBinDataList.GetMeasurementArray(var Arr: TMeasurementArray); +var + i, x: integer; + BinData: TBinData; +begin + SetLength(Arr, 0); + for i := 0 to Count - 1 do + begin + BinData := Items[i]; + for x := 0 to High(BinData.Values) do + begin + SetLength(Arr, Length(Arr) + 1); + Arr[High(Arr)] := BinData.Values[x]; + end; + end; +end; + +procedure TBinDataList.GenerateRandomData(const Count: Word; MinValue: Word = 0; MaxValue: Word = 360; FloatValues: Boolean = False); +var + Arr: TMeasurementArray; +begin + ClearParams; + FillMeasurementArrayWithRandomValues(Arr{%H-}, Count, MinValue, MaxValue, FloatValues); + ProcessMeasurementArray(Arr); +end; + +function TBinDataList.AsDebugStr: string; +var + BinData: TBinData; + sz: string; +begin + sz := 'Zero degrees belongs to the first bin'; + Result := + Self.ClassName + ENDL + + 'ClassSize: ' + itos(ClassSize) + ENDL + + 'Measurements: ' + itos(FStats.MeasurementCount) + ENDL + + 'MaxMeasurementsInBin: ' + itos(FStats.MaxMeasurementsInBin) + ENDL + + 'MinMeasurementsInBin: ' + itos(FStats.MinMeasurementsInBin) + ENDL + + 'Number of bins: ' + itos(Count) + ENDL + + sz + ENDL; + + for BinData in Self do + Result := Result + BinData.AsString + ENDL; +end; + +procedure TBinDataList.UpdateBins; +begin + ProcessMeasurementArray(FMeasurements); +end; + +procedure TBinDataList.SelectBin(const BinIndex: integer); +var + BinData: TBinData; +begin + BinData := Items[BinIndex]; + BinData.Selected := True; + Items[BinIndex] := BinData; +end; + +procedure TBinDataList.SelectBins(const NumberOfMeasurements: Word); +var + i: integer; + BinData: TBinData; +begin + for i := 0 to Count - 1 do + begin + BinData := Items[i]; + if BinData.MeasurementCount = NumberOfMeasurements then + begin + BinData.Selected := True; + Items[i] := BinData; + end; + end; +end; + +procedure TBinDataList.SelectMaxBins; +begin + SelectBins(FStats.MaxMeasurementsInBin); +end; + +procedure TBinDataList.SelectMinBins; +begin + SelectBins(FStats.MinMeasurementsInBin); +end; + +procedure TBinDataList.SelectAllBins; +var + i: integer; + BinData: TBinData; +begin + for i := 0 to Count - 1 do + begin + BinData := Items[i]; + BinData.Selected := True; + Items[i] := BinData; + end; +end; + +procedure TBinDataList.UnselectAllBins; +var + i: integer; + BinData: TBinData; +begin + for i := 0 to Count - 1 do + begin + BinData := Items[i]; + BinData.Selected := False; + Items[i] := BinData; + end; +end; + +procedure TBinDataList.InvertSelectedBins; +var + i: integer; + BinData: TBinData; +begin + for i := 0 to Count - 1 do + begin + BinData := Items[i]; + BinData.Selected := not BinData.Selected; + Items[i] := BinData; + end; +end; + + {$region ' CalculateStats '} + +{$IFNDEF FPC} // Delphi +procedure MeanAndStdDev(const Data: array of Single; var Mean, StdDev: Float); +var + xM, xSD: Single; +begin + Math.MeanAndStdDev(Data, xM, xSD); + Mean := xM; + StdDev := xSD; +end; +{$ENDIF} + +procedure TBinDataList.CalculateStats; +var + i, xCount: integer; + BinData: TBinData; + Arr: TMeasurementArray; +begin + FStats.Clear; + + FStats.BinCount := Self.Count; + GetMeasurementArray(Arr{%H-}); + FStats.MeasurementCount := Length(Arr); + FStats.SumOfMeasurements := Sum(Arr); + + if FStats.BinCount > 0 then FStats.MeasurementsPerBin := FStats.MeasurementCount / FStats.BinCount; + + + if FStats.MeasurementCount = 0 then FStats.MinMeasurementsInBin := 0 else FStats.MinMeasurementsInBin := High(FStats.MinMeasurementsInBin); + FStats.MaxMeasurementsInBin := 0; + + if FStats.MeasurementCount > 0 then + for i := 0 to Self.Count - 1 do + begin + BinData := Items[i]; + xCount := BinData.MeasurementCount; + + // I am looking for the range (bin) with the greatest and lowest number of measurements. + // The first value will be needed to determine the maximum radius when plotting a rose diagram. + if xCount > FStats.MaxMeasurementsInBin then FStats.MaxMeasurementsInBin := xCount; + if xCount < FStats.MinMeasurementsInBin then FStats.MinMeasurementsInBin := xCount; + + BinData.Percent := PercentValue(xCount, FStats.MeasurementCount); + + Items[i] := BinData; + end; + + + FStats.BinsWithMaxMeasurements := 0; + FStats.BinsWithMinMeasurements := 0; + if FStats.MeasurementCount > 0 then + for i := 0 to Count - 1 do + begin + xCount := Items[i].MeasurementCount; + if xCount = FStats.MaxMeasurementsInBin then Inc(FStats.BinsWithMaxMeasurements); + if xCount = FStats.MinMeasurementsInBin then Inc(FStats.BinsWithMinMeasurements); + end; + + + if FStats.MeasurementCount > 0 then + begin + FStats.MaxMeasurementsInBin_Percentage := PercentValue(FStats.MaxMeasurementsInBin, FStats.MeasurementCount); + MeanAndStdDev(Arr, FStats.Mean, FStats.StdDev); + end; +end; + {$endregion CalculateStats} + + +{$endregion TBinDataList} + + +{$region ' TBinData '} +function TBinData.AsString(Separator: string): string; +const + ValSep = ' / '; +var + i: integer; + LeftBracket: string; +begin + if BinIndex = 0 then LeftBracket := '<' else LeftBracket := '('; + Result := + Separator + '----------' + ENDL + + Separator + 'Bin No: ' + itos(No) + ENDL + + Separator + 'Measurements: ' + itos(MeasurementCount) + ENDL + + Separator + 'Percent: ' + ftos(Percent, 2) + '%' + ENDL + + Separator + 'Range: ' + LeftBracket + itos(Round(StartValue)) + ',' + itos(Round(EndValue)) + '>' + ENDL + + Separator + 'Selected: ' + BoolToStrYN(Selected); + + if Length(Values) > 0 then + begin + Result := Result + ENDL + Separator + 'Values (' + itos(Length(Values)) + '): '; + for i := 0 to High(Values) do Result := Result + ftos(Values[i], 2) + ValSep; + Result := TrimFromEnd(Result, ValSep); + end; +end; + +function TBinData.Mean: Float; +begin + if Self.MeasurementCount = 0 then Result := 0 + else Result := Math.Mean(Values); +end; + +function TBinData.StdDev: Float; +begin + if Self.MeasurementCount = 0 then Result := 0 + else Result := Math.StdDev(Values); +end; + +function TBinData.ValuesAsStr(Separator: string): string; +var + i: integer; +begin + Result := ''; + if Length(Values) = 0 then Exit; + for i := 0 to High(Values) do + Result := Result + ftos(Values[i]) + Separator; + Result := TStr.TrimFromEnd(Result, Separator); +end; + +function TBinData.MeasurementCount: Word; +begin + Result := Length(Values); +end; + +function TBinData.SumOfMeasurements: Double; +var + i: integer; +begin + Result := 0; + for i := 0 to High(Values) do Result := Result + Values[i]; +end; + +procedure TBinData.Clear; +begin + No := -1; + Percent := 0; + SetLength(Values, 0); + StartValue := 0; + EndValue := 0; + Selected := False; +end; +{$endregion TBinData} + +procedure TBinStats.Clear; +begin + BinCount := 0; + MeasurementCount := 0; + SumOfMeasurements := 0; + MeasurementsPerBin := 0; + MaxMeasurementsInBin := 0; + MinMeasurementsInBin := 0; + BinsWithMaxMeasurements := 0; + BinsWithMinMeasurements := 0; + MaxMeasurementsInBin_Percentage := 0; + Mean := 0; + StdDev := 0; +end; + + +end. + diff --git a/Graphics/JPL.RoseDiag.DataFile.pas b/Graphics/JPL.RoseDiag.DataFile.pas new file mode 100644 index 0000000..b19da82 --- /dev/null +++ b/Graphics/JPL.RoseDiag.DataFile.pas @@ -0,0 +1,945 @@ +unit JPL.RoseDiag.DataFile; + +{ + Jacek Pazera + https://www.pazera-software.com + https://github.com/jackdp + + License: public domain. + + 2022.06 +} + +{$I .\..\jp.inc} + +{$IFDEF FPC} + {$mode delphi}{$H+} +{$ELSE} + {$IFDEF DELPHIXE2_OR_BELOW} + Unit for Delphi XE3 or newer! + {$ENDIF} +{$ENDIF} + +interface + +{$IFDEF MSWINDOWS} + +uses + Classes, SysUtils, Graphics, Dialogs, + GdiPlus, GdiPlusHelpers, + JPL.Strings, JPL.Conversion, JPL.Colors, JPL.SimpleZip, + JPL.RoseDiag.Diagram, JPL.RoseDiag.BinDataList, + {$IFDEF FPC} + fpjson, JPL.JsonHelpers + {$ELSE} + JsonDataObjects, //<-- https://github.com/ahausladen/JsonDataObjects + JPL.JsonDataObjects + {$ENDIF} + ; + + +const + RD_FORMAT_VERSION = '1.0'; + RDID_MAIN_OBJECT = 'RoseDiagram'; // Object + + RDID_INFO = 'Info'; // Object + RDID_INFO_FORMAT_VERSION = 'FormatVersion'; // String + RDID_INFO_APPLICATION = 'Application'; + + RDID_METADATA = 'Metadata'; // Object + RDID_METADATA_AUTHOR = 'Author'; // String + RDID_METADATA_SUBJECT = 'Subject'; // String + RDID_METADATA_DESCRIPTION = 'Description'; // String + + RDID_MAIN = 'Main'; // Object + RDID_MAIN_RADIUS = 'Radius'; // Integer [mm] + RDID_MAIN_MARGIN = 'Margin'; // Integer [mm] + RDID_MAIN_CLASS_SIZE = 'ClassSize'; // Integer [degrees] + RDID_MAIN_DIAGRAM_TYPE = 'DiagramType'; // String: rose, polygon + RDID_MAIN_DRAW_POLYGON_INNER_LINES = 'DrawPolygonInnerLines'; // Boolean + RDID_MAIN_MEASUREMENT_TYPE = 'MeasurementType'; // String: azimuths, linear (0-360, 0-180) + RDID_MAIN_CENTRAL_SYMMETRY = 'CentralSymmetry'; // Boolean. Only for linear mesurements. + RDID_MAIN_LINEAR_MEASUREMENTS_FIX_MODE = 'LinearMeasurementsFixMode'; // String: normalize_180, remove + + RDID_BACKGROUND = 'Background'; // Object + RDID_BACKGROUND_COLOR = 'Color'; // String: HTML color + RDID_BACKGROUND_TRANSPARENCY = 'Transparency'; // Integer: 0..100 + + + RDID_LINE_OBJ_NAME = 'Line'; + RDID_FONT_OBJ_NAME = 'Font'; + RDID_FILL_OBJ_NAME = 'Fill'; + RDID_TEXT_OBJ_NAME = 'Text'; + RDID_PERCENT_MARKERS_OBJ_NAME = 'PercentMarkers'; + + RDID_LINE_VISIBLE = 'Visible'; // Boolean + RDID_LINE_COLOR = 'Color'; // String: HTML color + RDID_LINE_WIDTH = 'Width'; // Float + RDID_LINE_STYLE = 'Style'; // String + RDID_LINE_TRANSPARENCY = 'Transparency'; // Integer: 0..100 + + RDID_FONT_NAME = 'Name'; + RDID_FONT_SIZE = 'Size'; + RDID_FONT_COLOR = 'Color'; + RDID_FONT_STYLE = 'Style'; + RDID_FONT_TRANSPARENCY = 'Transparency'; + + RDID_FILL_BACKGROUND_COLOR = 'BackgroundColor'; // String: HTML color + RDID_FILL_TRANSPARENCY = 'FillTransparency'; // Integer: 0..100 + RDID_FILL_SOLID = 'SolidFill'; // Boolean + RDID_FILL_HATCH_STYLE = 'HatchStyle'; // String: hatch style ID + RDID_FILL_HATCH_COLOR = 'HatchColor'; // String: HTML color + + RDID_TEXT_VISIBLE = 'Visible'; // Boolean + RDID_TEXT_TEXT = 'Text'; // String + RDID_TEXT_POSITION_X = 'PosX'; // Float + RDID_TEXT_POSITION_Y = 'PosY'; // Float + + // Percentage markers (tick marks) + RDID_MARKER_VISIBLE = 'Visible'; // Boolean + RDID_MARKER_COLOR = 'Color'; // String: HTML color + RDID_MARKER_WIDTH = 'Width'; // Byte: 3..20 + RDID_MARKER_TRANSPARENCY = 'Transparency'; // Integer: 0..100 + + + RDID_FRAME = 'Frame'; // Object + RDID_CIRCLES = 'Circles'; // Object + RDID_CIRCLES_COUNT = 'Count'; // Integer + RDID_RADII = 'Radii'; // Object + RDID_AXES = 'Axes'; // Object + RDID_AXES_CAPTION_TYPE = 'CaptionType'; // String: degrees, symbols + RDID_PIES = 'Pies'; // Object + RDID_SELECTED_BINS = 'SelectedBins'; // Object + RDID_TITLE = 'Title'; // Object + RDID_DESCRIPTION = 'Description'; // Object + RDID_MEASUREMENTS = 'Measurements'; // Array of float values + + +type + + TRoseDataFileOption = (rdfoAll, rdfoMain, rdfoInfo, rdfoMetadata, rdfoBackground, rdfoFrame, rdfoCircles, rdfoRadii, + rdfoAxes, rdfoPies, rdfoSelectedBins, rdfoTitle, rdfoDescription, rdfoMeasurements); + TRoseDataFileOptions = set of TRoseDataFileOption; + + // Record helpers for sets: Delphi XE3 or newer + TRoseDataFileOptionsHelper = record helper for TRoseDataFileOptions + function SetAll: TRoseDataFileOptions; + function RemoveMeasurements: TRoseDataFileOptions; + end; + + TRoseDataFile = class + private + FRoseDiagram: TRoseDiagram; + FMeasurements: TMeasurementArray; + public + constructor Create(RoseDiagram: TRoseDiagram); + destructor Destroy; override; + + procedure SaveToFile(const FileName: string; ApplicationName: string = ''; ZipCompress: Boolean = False); overload; + procedure SaveToFile(const FileName: string; const Options: TRoseDataFileOptions; ApplicationName: string = ''; ZipCompress: Boolean = False); overload; + procedure SaveToString(out JsonStr: string; const Options: TRoseDataFileOptions; ApplicationName: string = ''); + + function LoadFromFile(const FileName: string; LoadMeasurements: Boolean): Boolean; overload; + function LoadFromFile(const FileName: string; const Options: TRoseDataFileOptions): Boolean; overload; + function LoadFromString(const JsonStr: string; const Options: TRoseDataFileOptions): Boolean; + + // Measurement list read from the file + property Measurements: TMeasurementArray read FMeasurements; + end; + + +{$ENDIF} // MSWINDOWS + + +implementation + + +{$IFDEF MSWINDOWS} + +{$region ' helpers '} +function PenStyleToStr(const PenStyle: TPenStyle): string; +begin + case PenStyle of + psSolid: Result := 'Solid'; + psDash: Result := 'Dash'; + psDot: Result := 'Dot'; + psDashDot: Result := 'DashDot'; + psDashDotDot: Result := 'DashDotDot'; + else + Result := 'Solid'; + end; +end; + +function StrToPenStyle(const PenStyleStr: string): TPenStyle; +var + s: string; +begin + s := Trim(LowerCase(PenStyleStr)); + if s = 'solid' then Result := psSolid + else if s = 'dash' then Result := psDash + else if s = 'dot' then Result := psDot + else if s = 'dashdot' then Result := psDashDot + else if s = 'dashdotdot' then Result := psDashDotDot + else Result := psSolid; +end; +{$endregion helpers} + + + + +constructor TRoseDataFile.Create(RoseDiagram: TRoseDiagram); +begin + inherited Create; + FRoseDiagram := RoseDiagram; +end; + +destructor TRoseDataFile.Destroy; +begin + inherited Destroy; +end; + +{$region ' Save to string / file '} +procedure TRoseDataFile.SaveToString(out JsonStr: string; const Options: TRoseDataFileOptions; ApplicationName: string = ''); +var + joRoot, joMainObj, joInfo, joMetadata, joMain, joBackground, joFrame, joCircles, joRadii, joAxes, joPies, joSelectedBins, + joTitle, joDescription: TJSONObject; + jaM: TJSONArray; + i: integer; + ArrM: TMeasurementArray; + bAll: Boolean; + + procedure WriteLineParams(jo: TJSONObject; const ID: string; Line: TRoseDiagramLine; WriteVisible: Boolean = True); + var + joLine: TJSONObject; + begin + joLine := TJSONObject.Create; + if WriteVisible then joLine.WriteBool(RDID_LINE_VISIBLE, Line.Visible); + joLine.WriteString(RDID_LINE_COLOR, ColorToHtmlColorStr(Line.Color)); + joLine.WriteFloat(RDID_LINE_WIDTH, Line.Width); + joLine.WriteString(RDID_LINE_STYLE, PenStyleToStr(Line.Style)); + joLine.WriteInteger(RDID_LINE_TRANSPARENCY, Line.Transparency); + jo.AddObject(ID, joLine, False); + end; + + procedure WriteFillParams(jo: TJSONObject; const ID: string; Fill: TRoseDiagramFill); + var + joFill: TJSONObject; + begin + joFill := TJSONObject.Create; + joFill.WriteString(RDID_FILL_BACKGROUND_COLOR, ColorToHtmlColorStr(Fill.Color)); + joFill.WriteInteger(RDID_FILL_TRANSPARENCY, Fill.Transparency); + joFill.WriteBool(RDID_FILL_SOLID, Fill.SolidFill); + joFill.WriteString(RDID_FILL_HATCH_STYLE, string(HatchStyleToStrID(Fill.HatchStyle))); + joFill.WriteString(RDID_FILL_HATCH_COLOR, ColorToHtmlColorStr(Fill.HatchColor)); + jo.AddObject(ID, joFill, False); + end; + + procedure WriteFontParams(jo: TJSONObject; const ID: string; Font: TRoseDiagramFont); + var + joFont: TJSONObject; + begin + joFont := TJSONObject.Create; + joFont.WriteString(RDID_FONT_NAME, Font.FontName); + joFont.WriteInteger(RDID_FONT_SIZE, Font.Size); + joFont.WriteString(RDID_FONT_COLOR, ColorToHtmlColorStr(Font.Color)); + joFont.WriteString(RDID_FONT_STYLE, string(GPFontStyleToStr(Font.Style))); + joFont.WriteInteger(RDID_FONT_TRANSPARENCY, Font.Transparency); + jo.AddObject(ID, joFont, False); + end; + + procedure WriteTextParams(jo: TJSONObject; const ID: string; Text: TRoseDiagramText; WriteText, WritePosition: Boolean); + var + joText: TJSONObject; + begin + joText := TJSONObject.Create; + joText.WriteBool(RDID_TEXT_VISIBLE, Text.Visible); + WriteFontParams(joText, RDID_FONT_OBJ_NAME, Text.Font); + if WriteText then joText.WriteString(RDID_TEXT_TEXT, Text.Text); + if WritePosition then + begin + joText.WriteFloat(RDID_TEXT_POSITION_X, Text.PosX); + joText.WriteFloat(RDID_TEXT_POSITION_Y, Text.PosY); + end; + jo.AddObject(ID, joText, False); + end; + + procedure WriteMarkerParams(jo: TJSONObject; const ID: string; Marker: TRoseDiagramAxisMarker); + var + joMarker: TJSONObject; + begin + joMarker := TJSONObject.Create; + joMarker.WriteBool(RDID_MARKER_VISIBLE, Marker.Visible); + WriteFontParams(joMarker, RDID_FONT_OBJ_NAME, Marker.Font); + joMarker.WriteString(RDID_MARKER_COLOR, ColorToHtmlColorStr(Marker.MarkerColor)); + joMarker.WriteInteger(RDID_MARKER_WIDTH, Marker.MarkerWidth); + joMarker.WriteInteger(RDID_MARKER_TRANSPARENCY, Marker.MarkerTransparency); + jo.AddObject(ID, joMarker, False); + end; + +begin + JsonStr := ''; + joRoot := TJSONObject.Create; + joMainObj := TJSONObject.Create; + joInfo := TJSONObject.Create; + joMetadata := TJSONObject.Create; + joMain := TJSONObject.Create; + joBackground := TJSONObject.Create; + joFrame := TJSONObject.Create; + joCircles := TJSONObject.Create; + joRadii := TJSONObject.Create; + joAxes := TJSONObject.Create; + joPies := TJSONObject.Create; + joSelectedBins := TJSONObject.Create; + joTitle := TJSONObject.Create; + joDescription := TJSONObject.Create; + jaM := TJSONArray.Create; + try + + bAll := rdfoAll in Options; + + // Info + if bAll or (rdfoInfo in Options) then + begin + joInfo.WriteString(RDID_INFO_FORMAT_VERSION, RD_FORMAT_VERSION); + joInfo.WriteString(RDID_INFO_APPLICATION, ApplicationName); + joMainObj.AddObject(RDID_INFO, joInfo); + end; + + // Metadata + if bAll or (rdfoMetadata in Options) then + begin + joMetadata.WriteString(RDID_METADATA_AUTHOR, FRoseDiagram.Metadata.Author); + joMetadata.WriteString(RDID_METADATA_SUBJECT, FRoseDiagram.Metadata.Subject); + joMetadata.WriteString(RDID_METADATA_DESCRIPTION, FRoseDiagram.Metadata.Description); + joMainObj.AddObject(RDID_METADATA, joMetadata); + end; + + // Main options + if bAll or (rdfoMain in Options) then + begin + joMain.WriteInteger(RDID_MAIN_RADIUS, FRoseDiagram.RadiusMM); + joMain.WriteInteger(RDID_MAIN_MARGIN, FRoseDiagram.MarginMM); + joMain.WriteInteger(RDID_MAIN_CLASS_SIZE, FRoseDiagram.ClassSize); + joMain.WriteString(RDID_MAIN_DIAGRAM_TYPE, RoseDiagramTypeToStrID(FRoseDiagram.DiagramType)); + joMain.WriteBool(RDID_MAIN_DRAW_POLYGON_INNER_LINES, FRoseDiagram.DrawInternalPolygonLines); + joMain.WriteString(RDID_MAIN_MEASUREMENT_TYPE, RoseMeasurementTypeToStrID(FRoseDiagram.MeasurementType)); + joMain.WriteBool(RDID_MAIN_CENTRAL_SYMMETRY, FRoseDiagram.CentralSymmetry); + joMain.WriteString(RDID_MAIN_LINEAR_MEASUREMENTS_FIX_MODE, LinearMeasurementFixModeToStrID(FRoseDiagram.BinDataList.LinearMeasurementFixMode)); + joMainObj.AddObject(RDID_MAIN, joMain); + end; + + // Background + if bAll or (rdfoBackground in Options) then + begin + joBackground.WriteString(RDID_BACKGROUND_COLOR, ColorToHtmlColorStr(FRoseDiagram.Background.Color)); + joBackground.WriteInteger(RDID_BACKGROUND_TRANSPARENCY, FRoseDiagram.Background.Transparency); + joMainObj.AddObject(RDID_BACKGROUND, joBackground); + end; + + // Frame + if bAll or (rdfoFrame in Options) then + begin + WriteLineParams(joFrame, RDID_LINE_OBJ_NAME, FRoseDiagram.Frame, True); + joMainObj.AddObject(RDID_FRAME, joFrame); + end; + + // Circles + if bAll or (rdfoCircles in Options) then + begin + joCircles.WriteInteger(RDID_CIRCLES_COUNT, FRoseDiagram.CirclesCount); + WriteLineParams(joCircles, RDID_LINE_OBJ_NAME, FRoseDiagram.Circles, True); + joMainObj.AddObject(RDID_CIRCLES, joCircles); + end; + + // Radii + if bAll or (rdfoRadii in Options) then + begin + WriteLineParams(joRadii, RDID_LINE_OBJ_NAME, FRoseDiagram.Radii, True); + joMainObj.AddObject(RDID_RADII, joRadii); + end; + + // Axes + if bAll or (rdfoAxes in Options) then + begin + WriteLineParams(joAxes, RDID_LINE_OBJ_NAME, FRoseDiagram.Axes.Line, True); + joAxes.WriteString(RDID_AXES_CAPTION_TYPE, AxesCaptionTypeToStrID(FRoseDiagram.Axes.CaptionType)); + WriteTextParams(joAxes, RDID_TEXT_OBJ_NAME, FRoseDiagram.Axes.Text, False, False); + WriteMarkerParams(joAxes, RDID_PERCENT_MARKERS_OBJ_NAME, FRoseDiagram.Axes.PercentageMarkers); + joMainObj.AddObject(RDID_AXES, joAxes); + end; + + // Pies + if bAll or (rdfoPies in Options) then + begin + WriteLineParams(joPies, RDID_LINE_OBJ_NAME, FRoseDiagram.PieLine, False); + WriteFillParams(joPies, RDID_FILL_OBJ_NAME, FRoseDiagram.PieFill); + joMainObj.AddObject(RDID_PIES, joPies); + end; + + // Selected bins + if bAll or (rdfoSelectedBins in Options) then + begin + WriteLineParams(joSelectedBins, RDID_LINE_OBJ_NAME, FRoseDiagram.SelectedBinLine, False); + WriteFillParams(joSelectedBins, RDID_FILL_OBJ_NAME, FRoseDiagram.SelectedBinFill); + joMainObj.AddObject(RDID_SELECTED_BINS, joSelectedBins); + end; + + // Title + if bAll or (rdfoTitle in Options) then + begin + WriteTextParams(joTitle, RDID_TEXT_OBJ_NAME, FRoseDiagram.Title, True, True); + joMainObj.AddObject(RDID_TITLE, joTitle); + end; + + // Description + if bAll or (rdfoDescription in Options) then + begin + WriteTextParams(joDescription, RDID_TEXT_OBJ_NAME, FRoseDiagram.Description, True, True); + joMainObj.AddObject(RDID_DESCRIPTION, joDescription); + end; + + // Measurements + if bAll or (rdfoMeasurements in Options) then + begin + ArrM := FRoseDiagram.BinDataList.Measurements; + + {$IFDEF FPC} + for i := 0 to High(ArrM) do jaM.Add(ArrM[i]); + {$ELSE} + jaM.Count := Length(ArrM); + for i := 0 to High(ArrM) do jaM.F[i] := ArrM[i]; + {$ENDIF} + joMainObj.AddArray(RDID_MEASUREMENTS, jaM, True); + end; + + + joRoot.AddObject(RDID_MAIN_OBJECT, joMainObj); + {$IFDEF FPC} + JsonStr := joRoot.FormatJSON; + {$ELSE} + JsonStr := joRoot.ToJSON(False); + {$ENDIF} + + + finally + joMainObj.Free; + joInfo.Free; + joMetadata.Free; + joMain.Free; + joBackground.Free; + joFrame.Free; + joCircles.Free; + joRadii.Free; + joAxes.Free; + joPies.Free; + joRoot.Free; + joSelectedBins.Free; + joTitle.Free; + joDescription.Free; + jaM.Free; + end; +end; + +procedure TRoseDataFile.SaveToFile(const FileName: string; const Options: TRoseDataFileOptions; ApplicationName: string = ''; ZipCompress: Boolean = False); +var + JsonStr: string; +begin + SaveToString(JsonStr, Options, ApplicationName); + if ZipCompress then SaveStringToZipFile(FileName, JsonStr, BaseFileName(FileName) + '.roz', 'Rose diagram') + else SaveStringToFile(FileName, JsonStr, TEncoding.UTF8, False); +end; + +procedure TRoseDataFile.SaveToFile(const FileName: string; ApplicationName: string = ''; ZipCompress: Boolean = False); +var + Options: TRoseDataFileOptions; +begin + Options := {%H-}Options.SetAll; + SaveToFile(FileName, Options, ApplicationName, ZipCompress); +end; +{$endregion Save to string / file} + + +{$region ' Load from string / file '} + +function TRoseDataFile.LoadFromString(const JsonStr: string; const Options: TRoseDataFileOptions): Boolean; +var + joRoot, joMainObj, joInfo, joMetadata, joMain, joBackground, joFrame, joCircles, joRadii, joAxes, joPies, joSelectedBins, + joTitle, joDescription: TJSONObject; + jaM: TJSONArray; + s: string; + i, x: integer; + cl: TColor; + xf: Single; + FixMode: TLinearMeasurementFixMode; + bAll: Boolean; + + + procedure ReadLineParams(jo: TJSONObject; const ID: string; Line: TRoseDiagramLine; ReadVisible: Boolean = True); + var + joLine: TJSONObject; + begin + if not jo.TryGetObject(ID, joLine) then Exit; + + // Visible + if ReadVisible then Line.Visible := joLine.ReadBool(RDID_LINE_VISIBLE, Line.Visible); + + // Color + s := joLine.ReadString(RDID_LINE_COLOR, ColorToHtmlColorStr(Line.Color)); + if TryHtmlStrToColor(s, cl) then Line.Color := cl; + + // Width + xf := joLine.ReadFloat(RDID_LINE_WIDTH, Line.Width); + xf := GetFloatInRange(xf, RD_MIN_LINE_WIDTH, RD_MAX_LINE_WIDTH); + Line.Width := xf; + + // Style + s := joLine.ReadString(RDID_LINE_STYLE, PenStyleToStr(Line.Style)); + Line.Style := StrToPenStyle(s); + + // Transparency + x := joLine.ReadInteger(RDID_LINE_TRANSPARENCY, Line.Transparency); + x := GetIntInRange(x, 0, 100); + Line.Transparency := x; + end; + + procedure ReadFillParams(jo: TJSONObject; const ID: string; Fill: TRoseDiagramFill); + var + joFill: TJSONObject; + hs: TGPHatchStyle; + begin + if not jo.TryGetObject(ID, joFill) then Exit; + + // Background color + s := joFill.ReadString(RDID_FILL_BACKGROUND_COLOR, ColorToHtmlColorStr(Fill.Color)); + if TryHtmlStrToColor(s, cl) then Fill.Color := cl; + + // Fill transparency + x := joFill.ReadInteger(RDID_FILL_TRANSPARENCY, Fill.Transparency); + x := GetIntInRange(x, 0, 100); + Fill.Transparency := x; + + // Solid fill + Fill.SolidFill := joFill.ReadBool(RDID_FILL_SOLID, Fill.SolidFill); + + // Hatch style + s := joFill.ReadString(RDID_FILL_HATCH_STYLE, string(HatchStyleToStrID(Fill.HatchStyle))); + if TryStrIDToHatchStyle(UnicodeString(s), hs{%H-}) then Fill.HatchStyle := hs; + + // Hatch color + s := joFill.ReadString(RDID_FILL_HATCH_COLOR, ColorToHtmlColorStr(Fill.HatchColor)); + if TryHtmlStrToColor(s, cl) then Fill.HatchColor := cl; + end; + + procedure ReadFontParams(jo: TJSONObject; const ID: string; Font: TRoseDiagramFont); + var + joFont: TJSONObject; + begin + if not jo.TryGetObject(ID, joFont) then Exit; + + // Font name + s := joFont.ReadString(RDID_FONT_NAME, Font.FontName); + CheckGPFontName(s, False); + Font.FontName := s; + + // Font size + x := joFont.ReadInteger(RDID_FONT_SIZE, Font.Size); + x := GetIntInRange(x, 1, RD_MAX_FONT_SIZE); + Font.Size := x; + + // Font color + s := joFont.ReadString(RDID_FONT_COLOR, ColorToHtmlColorStr(Font.Color)); + if TryHtmlStrToColor(s, cl) then Font.Color := cl; + + // Font style + s := joFont.ReadString(RDID_FONT_STYLE, string(GPFontStyleToStr(Font.Style))); + Font.Style := StrToGPFontStyle(UnicodeString(s)); + + // Font transparency + x := joFont.ReadInteger(RDID_FONT_TRANSPARENCY, Font.Transparency); + x := GetIntInRange(x, 0, 100); + Font.Transparency := x; + end; + + procedure ReadTextParams(jo: TJSONObject; const ID: string; Text: TRoseDiagramText; ReadText, ReadPosition: Boolean); + var + joText: TJSONObject; + begin + if not jo.TryGetObject(ID, joText) then Exit; + + // Visible + Text.Visible := joText.ReadBool(RDID_TEXT_VISIBLE, Text.Visible); + + // Font + ReadFontParams(joText, RDID_FONT_OBJ_NAME, Text.Font); + + if ReadText then + begin + s := joText.ReadString(RDID_TEXT_OBJ_NAME, Text.Text); + if Length(s) > RD_MAX_TEXT_LEN then s := Copy(s, 1, RD_MAX_TEXT_LEN); + Text.Text := s; + end; + + if ReadPosition then + begin + // PosX + xf := joText.ReadFloat(RDID_TEXT_POSITION_X, Text.PosX); + xf := GetFloatInRange(xf, 0, RD_MAX_POS); + Text.PosX := xf; + + // PosY + xf := joText.ReadFloat(RDID_TEXT_POSITION_Y, Text.PosY); + xf := GetFloatInRange(xf, 0, RD_MAX_POS); + Text.PosY := xf; + end; + end; + + procedure ReadMarkerParams(jo: TJSONObject; const ID: string; Marker: TRoseDiagramAxisMarker); + var + joMarker: TJSONObject; + begin + if not jo.TryGetObject(ID, joMarker) then Exit; + + // Visible + Marker.Visible := joMarker.ReadBool(RDID_MARKER_VISIBLE, Marker.Visible); + + // Font + ReadFontParams(joMarker, RDID_FONT_OBJ_NAME, Marker.Font); + + // Marker color + s := joMarker.ReadString(RDID_MARKER_COLOR, ColorToHtmlColorStr(Marker.MarkerColor)); + if TryHtmlStrToColor(s, cl) then Marker.MarkerColor := cl; + + // Marker width (length) + x := joMarker.ReadInteger(RDID_MARKER_WIDTH, Marker.MarkerWidth); + x := GetIntInRange(x, RD_MIN_MARKER_WIDTH, RD_MAX_MARKER_WIDTH); + Marker.MarkerWidth := x; + + // Marker transparency + x := joMarker.ReadInteger(RDID_MARKER_TRANSPARENCY, Marker.MarkerTransparency); + x := GetIntInRange(x, 0, 100); + Marker.MarkerTransparency := x; + end; + + function ImportFromRozeta2DataStr: Boolean; + var + sl: TStringList; + i: integer; + begin + FRoseDiagram.BinDataList.ClearParams; + SetLength(FMeasurements, 0); + + sl := TStringList.Create; + try + sl.Text := JsonStr; + for i := 0 to sl.Count - 1 do + begin + s := Trim(sl[i]); + if s = '' then Continue; + if Copy(s, 1, 1) = ';' then Continue; + s := TrimFromCharPosToEnd(s, '/'); + if not TryStoF(s, xf) then Continue; + SetLength(FMeasurements, Length(FMeasurements) + 1); + FMeasurements[High(FMeasurements)] := xf; + end; + finally + sl.Free; + end; + + FRoseDiagram.BinDataList.ProcessMeasurementArray(FMeasurements); + Result := Length(FMeasurements) > 0; + end; + +begin + Result := False; + bAll := rdfoAll in Options; + + try + joRoot := GetJSONObjectFromStr(JsonStr, False); + except + //on E: Exception do + // raise Exception.Create('Invalid data file: "' + ExpandFileName(FileName) + '"' + ENDL + ENDL + E.Message); + + Result := ImportFromRozeta2DataStr; + Exit; + end; + + if not Assigned(joRoot) then Exit; + + try + + if not joRoot.TryGetObject(RDID_MAIN_OBJECT, joMainObj) then Exit; + + {$region ' Info '} + if bAll or (rdfoInfo in Options) then + begin + if joMainObj.TryGetObject(RDID_INFO, joInfo) then + begin + s := joInfo.ReadString(RDID_INFO_FORMAT_VERSION, ''); + if s <> RD_FORMAT_VERSION then + begin + Exception.Create('Invalid version number in JSON data: ' + s + ENDL + 'Expected: ' + RD_FORMAT_VERSION); + Exit; + end; + end; + end; + {$endregion Info} + + + {$region ' Metadata '} + if bAll or (rdfoMetadata in Options) then + begin + if joMainObj.TryGetObject(RDID_METADATA, joMetadata) then + begin + FRoseDiagram.Metadata.Subject := joMetadata.ReadString(RDID_METADATA_SUBJECT, FRoseDiagram.Metadata.Subject); + FRoseDiagram.Metadata.Author := joMetadata.ReadString(RDID_METADATA_AUTHOR, FRoseDiagram.Metadata.Author); + FRoseDiagram.Metadata.Description := joMetadata.ReadString(RDID_METADATA_DESCRIPTION, FRoseDiagram.Metadata.Description); + end; + end; + {$endregion Metadata} + + + {$region ' Main options '} + if bAll or (rdfoMain in Options) then + begin + if joMainObj.TryGetObject(RDID_MAIN, joMain) then + begin + // Radius [mm] + x := joMain.ReadInteger(RDID_MAIN_RADIUS, FRoseDiagram.RadiusMM); + x := GetIntInRange(x, RD_MIN_DIAGRAM_WIDTH_MM, RD_MAX_DIAGRAM_WIDTH_MM); + FRoseDiagram.RadiusMM := x; + + // Margin [mm] + x := joMain.ReadInteger(RDID_MAIN_MARGIN, FRoseDiagram.MarginMM); + x := GetIntInRange(x, RD_MIN_DIAGRAM_MARGIN_MM, RD_MAX_DIAGRAM_MARGIN_MM); + FRoseDiagram.MarginMM := x; + + // Class size + x := joMain.ReadInteger(RDID_MAIN_CLASS_SIZE, FRoseDiagram.ClassSize); + if not IsValidClassSize(x) then x := RD_DEFAULT_CLASS_SIZE; + FRoseDiagram.ClassSize := x; + + // Diagram type + s := joMain.ReadString(RDID_MAIN_DIAGRAM_TYPE, RoseDiagramTypeToStrID(FRoseDiagram.DiagramType)); + FRoseDiagram.DiagramType := StrIDToRoseDiagramType(s); + + // Draw polygon inner lines + FRoseDiagram.DrawInternalPolygonLines := joMain.ReadBool(RDID_MAIN_DRAW_POLYGON_INNER_LINES, FRoseDiagram.DrawInternalPolygonLines); + + // Measurement type + s := joMain.ReadString(RDID_MAIN_MEASUREMENT_TYPE, RoseMeasurementTypeToStrID(FRoseDiagram.MeasurementType)); + FRoseDiagram.MeasurementType := StrIDToRoseMeasurementType(s); + + // Central symmetry + FRoseDiagram.CentralSymmetry := joMain.ReadBool(RDID_MAIN_CENTRAL_SYMMETRY, FRoseDiagram.CentralSymmetry); + + // Linear measurements fix mode + FixMode := FRoseDiagram.BinDataList.LinearMeasurementFixMode; + s := joMain.ReadString(RDID_MAIN_LINEAR_MEASUREMENTS_FIX_MODE, LinearMeasurementFixModeToStrID(FixMode)); + FixMode := StrIDToLinearMeasurementFixMode(s, FixMode); + FRoseDiagram.BinDataList.LinearMeasurementFixMode := FixMode; + + end; + end; + {$endregion Size} + + + {$region ' Background '} + if bAll or (rdfoBackground in Options) then + begin + if joMainObj.TryGetObject(RDID_BACKGROUND, joBackground) then + begin + // Color + s := joBackground.ReadString(RDID_BACKGROUND_COLOR, ColorToHtmlColorStr(FRoseDiagram.Background.Color)); + if TryHtmlStrToColor(s, cl) then FRoseDiagram.Background.Color := cl; + + // Transparency + x := joBackground.ReadInteger(RDID_BACKGROUND_TRANSPARENCY, FRoseDiagram.Background.Transparency); + x := GetIntInRange(x, 0, 100); + FRoseDiagram.Background.Transparency := x; + end; + end; + {$endregion Background} + + + {$region ' Frame '} + if bAll or (rdfoFrame in Options) then + begin + if joMainObj.TryGetObject(RDID_FRAME, joFrame) then ReadLineParams(joFrame, RDID_LINE_OBJ_NAME, FRoseDiagram.Frame, True); + end; + {$endregion Frame} + + + {$region ' Circles '} + if bAll or (rdfoCircles in Options) then + begin + if joMainObj.TryGetObject(RDID_CIRCLES, joCircles) then + begin + ReadLineParams(joCircles, RDID_LINE_OBJ_NAME, FRoseDiagram.Circles, True); + + // Count + x := joCircles.ReadInteger(RDID_CIRCLES_COUNT, FRoseDiagram.CirclesCount); + x := GetIntInRange(x, 1, RD_MAX_CIRCLES_COUNT); + FRoseDiagram.CirclesCount := x; + end; + end; + {$endregion Circles} + + + {$region ' Radii '} + if bAll or (rdfoRadii in Options) then + begin + if joMainObj.TryGetObject(RDID_RADII, joRadii) then ReadLineParams(joRadii, RDID_LINE_OBJ_NAME, FRoseDiagram.Radii, True); + end; + {$endregion Radii} + + + {$region ' Axes '} + if bAll or (rdfoAxes in Options) then + begin + if joMainObj.TryGetObject(RDID_AXES, joAxes) then + begin + ReadLineParams(joAxes, RDID_LINE_OBJ_NAME, FRoseDiagram.Axes.Line, True); + ReadTextParams(joAxes, RDID_TEXT_OBJ_NAME, FRoseDiagram.Axes.Text, False, False); + ReadMarkerParams(joAxes, RDID_PERCENT_MARKERS_OBJ_NAME, FRoseDiagram.Axes.PercentageMarkers); + + // Caption type + s := joAxes.ReadString(RDID_AXES_CAPTION_TYPE, AxesCaptionTypeToStrID(FRoseDiagram.Axes.CaptionType)); + FRoseDiagram.Axes.CaptionType := StrIDToAxesCaptionType(s); + end; + end; + {$endregion Axes} + + + {$region ' Pies '} + if bAll or (rdfoPies in Options) then + begin + if joMainObj.TryGetObject(RDID_PIES, joPies) then + begin + ReadLineParams(joPies, RDID_LINE_OBJ_NAME, FRoseDiagram.PieLine, False); + ReadFillParams(joPies, RDID_FILL_OBJ_NAME, FRoseDiagram.PieFill); + end; + end; + {$endregion Pies} + + + {$region ' Selected bins '} + if bAll or (rdfoSelectedBins in Options) then + begin + if joMainObj.TryGetObject(RDID_SELECTED_BINS, joSelectedBins) then + begin + ReadLineParams(joSelectedBins, RDID_LINE_OBJ_NAME, FRoseDiagram.SelectedBinLine, False); + ReadFillParams(joSelectedBins, RDID_FILL_OBJ_NAME, FRoseDiagram.SelectedBinFill); + end; + end; + {$endregion Selected bins} + + + {$region ' Title '} + if bAll or (rdfoTitle in Options) then + begin + if joMainObj.TryGetObject(RDID_TITLE, joTitle) then + ReadTextParams(joTitle, RDID_TEXT_TEXT, FRoseDiagram.Title, True, True); + end; + {$endregion Title} + + + {$region ' Description '} + if bAll or (rdfoDescription in Options) then + begin + if joMainObj.TryGetObject(RDID_DESCRIPTION, joDescription) then + ReadTextParams(joDescription, RDID_TEXT_TEXT, FRoseDiagram.Description, True, True); + end; + {$endregion Description} + + + {$region ' Measurements '} + if bAll or (rdfoMeasurements in Options) then + begin + FRoseDiagram.BinDataList.ClearParams; + SetLength(FMeasurements{%H-}, 0); + if joMainObj.TryGetArray(RDID_MEASUREMENTS, jaM) then + begin + + for i := 0 to jaM.Count - 1 do + begin + {$IFDEF FPC} + if not jaM[i].IsNumber then Continue; + xf := jaM[i].AsFloat; + {$ELSE} + if not IsNumberDataType(jaM[i].Typ) then Continue; + xf := jaM[i].FloatValue; + {$ENDIF} + SetLength(FMeasurements, Length(FMeasurements) + 1); + FMeasurements[High(FMeasurements)] := xf; + end; + + // FMeasurements stores all float values read from the file. + // ProcessMeasurementArray can change / delete measurements during processing. + + FRoseDiagram.BinDataList.ProcessMeasurementArray(FMeasurements); + end; + end; + {$endregion Measurements} + + + Result := True; + + finally + if Assigned(joRoot) then joRoot.Free; + end; +end; + + +function TRoseDataFile.LoadFromFile(const FileName: string; const Options: TRoseDataFileOptions): Boolean; +var + JsonStr: string; +begin + Result := False; + if IsZipFile(FileName) then + begin + JsonStr := GetStringFromZipFile(FileName, TEncoding.UTF8, '', 0); + if JsonStr = '' then Exit; + end + else + if not LoadStringFromFile(FileName, JsonStr{%H-}, TEncoding.UTF8, True) then Exit; + + Result := LoadFromString(JsonStr, Options); +end; + + +function TRoseDataFile.LoadFromFile(const FileName: string; LoadMeasurements: Boolean): Boolean; +var + Options: TRoseDataFileOptions; +begin + Options := {%H-}Options.SetAll; + if not LoadMeasurements then Options := Options.RemoveMeasurements; + Result := LoadFromFile(FileName, Options); +end; + + + +{$endregion Load from string / file} + + + +{ TRoseDataFileOptionsHelper } + +function TRoseDataFileOptionsHelper.SetAll: TRoseDataFileOptions; +begin + Result := [ + rdfoMain, rdfoInfo, rdfoMetadata, rdfoBackground, rdfoFrame, rdfoCircles, rdfoRadii, + rdfoAxes, rdfoPies, rdfoSelectedBins, rdfoTitle, rdfoDescription, rdfoMeasurements + ]; +end; + +function TRoseDataFileOptionsHelper.RemoveMeasurements: TRoseDataFileOptions; +begin + Result := Self - [rdfoMeasurements]; +end; + + +{$ENDIF} + + +end. + diff --git a/Graphics/JPL.RoseDiag.Diagram.pas b/Graphics/JPL.RoseDiag.Diagram.pas new file mode 100644 index 0000000..ea02090 --- /dev/null +++ b/Graphics/JPL.RoseDiag.Diagram.pas @@ -0,0 +1,1335 @@ +unit JPL.RoseDiag.Diagram; + +{ + Jacek Pazera + https://www.pazera-software.com + https://github.com/jackdp + + License: public domain. + + 2022.06 +} + +{$I .\..\jp.inc} + +{$IFDEF FPC} + {$mode delphi}{$H+} +{$ENDIF} + +interface + +{$IFDEF MSWINDOWS} +uses + Classes, SysUtils, Graphics, + GdiPlus, GdiPlusHelpers, + JPL.RoseDiag.BinDataList, + JPL.TStr, JPL.Math, JPL.Conversion, JPL.Colors, JPL.PixelConv; +{$ENDIF} // MSWINDOWS + +const + RD_DEFAULT_CLASS_SIZE = 10; + +{$IFDEF MSWINDOWS} + RD_MIN_DIAGRAM_WIDTH_MM = 10; + RD_MAX_DIAGRAM_WIDTH_MM = 1000; + RD_MIN_DIAGRAM_MARGIN_MM = 0; + RD_MAX_DIAGRAM_MARGIN_MM = 100; + RD_MIN_LINE_WIDTH = 0.1; + RD_MAX_LINE_WIDTH = 10.0; + RD_MAX_CIRCLES_COUNT = 90; + RD_MAX_FONT_SIZE = 40; + RD_MAX_POS = 500; + RD_MAX_TEXT_LEN = 500; + RD_MIN_MARKER_WIDTH = 1; + RD_MAX_MARKER_WIDTH = 20; + + DEG_SIGN = '°'; + + // Integer divisors of 360 (except 360) + // NOTE: Być może lepiej zastosować dzielniki całkowite 90 + ClassSizeArray: array[0..22] of Byte = + ( + 1, 2, 3, 4, 5, 6, 8, 9, + 10, 12, 15, 18, + 20, 24, + 30, 36, 40, 45, 60, 72, 90, + 120, 180 + ); + + + +type + + Int100 = 0..100; + + TRoseDiagramType = (rdtRose, rdtPolygon); + TMeasurementType = (mt360, mt180); // mt360 - azimuths 0-360 (full circle), mt180 - linear data 0-180 (half cicle or full if CentralSymmetry = True) + TAxesCaptionType = (actDegrees, actSymbols); // actDegrees - 0,90,180,270; actSymbols - N,E,S,W + + TRoseDiagramFill = class + private + FColor: TColor; + FHatchColor: TColor; + FHatchStyle: TGPHatchStyle; + FSolidFill: Boolean; + FTransparency: Int100; + public + procedure SetProperties(const AColor: TColor; const ATransparency: Int100; const AHatchStyle: TGPHatchStyle; const AHatchColor: TColor; + const ASolidFill: Boolean); + + property Color: TColor read FColor write FColor; // Hatch background color or solid color if SolidFill = True + property Transparency: Int100 read FTransparency write FTransparency; // Transparency in percent + property HatchStyle: TGPHatchStyle read FHatchStyle write FHatchStyle; // Ignored if SolidFill = True + property HatchColor: TColor read FHatchColor write FHatchColor; // Kolor kreskowania (szrafury). Ignored if SolidFill = True + property SolidFill: Boolean read FSolidFill write FSolidFill; // Solid fill (no hatch) + end; + + TRoseDiagramLine = class + private + FColor: TColor; + FStyle: TPenStyle; + FTransparency: Int100; + FVisible: Boolean; + FWidth: Single; + public + procedure SetProperties(const AVisible: Boolean; const AColor: TColor; const ATransparency: Int100; const AWidth: Single; + const AStyle: TPenStyle); + + property Visible: Boolean read FVisible write FVisible; + property Color: TColor read FColor write FColor; + property Transparency: Int100 read FTransparency write FTransparency; + property Width: Single read FWidth write FWidth; // Pen width + property Style: TPenStyle read FStyle write FStyle; + end; + + TRoseDiagramFont = class + private + FColor: TColor; + FFontName: string; + FSize: Byte; + FStyle: TGPFontStyle; + FTransparency: Int100; + procedure SetFontName(AValue: string); + public + procedure SetProperties(const AFontName: string; const ASize: Byte; const AStyle: TGPFontStyle; const AColor: TColor; + const ATransparency: Int100); + procedure Assign(AFont: TRoseDiagramFont); + + property FontName: string read FFontName write SetFontName; + property Size: Byte read FSize write FSize; // Size in points + property Color: TColor read FColor write FColor; + property Style: TGPFontStyle read FStyle write FStyle; + property Transparency: Int100 read FTransparency write FTransparency; + end; + + TRoseDiagramText = class + private + FFont: TRoseDiagramFont; + FVisible: Boolean; + FPosX: Single; + FPosY: Single; + FText: string; + procedure SetFont(AValue: TRoseDiagramFont); + public + constructor Create; + destructor Destroy; override; + + procedure SetProperties(const AVisible: Boolean; const AText, AFontName: string; const AFontSizePt: Byte; const AFontStyle: TGPFontStyle; + const AFontColor: TColor; const APosX, APosY: Single; const AFontTransparency: Int100); + + property Visible: Boolean read FVisible write FVisible; + property Text: string read FText write FText; + property Font: TRoseDiagramFont read FFont write SetFont; + property PosX: Single read FPosX write FPosX; + property PosY: Single read FPosY write FPosY; + end; + + TRoseDiagramAxisMarker = class + private + FVisible: Boolean; + FFont: TRoseDiagramFont; + FMarkerColor: TColor; + FMarkerTransparency: Int100; + FMarkerWidth: Byte; + procedure SetFont(AValue: TRoseDiagramFont); + public + constructor Create; + destructor Destroy; override; + + procedure SetProperties(const AVisible: Boolean; const AFontName: string; const AFontSizePt: Byte; const AFontStyle: TGPFontStyle; + const AFontColor: TColor; const AFontTransparency: Int100; const AMarkerColor: TColor; const AMarkerWidth: Byte; + const AMarkerTransparency: Int100); + + property Visible: Boolean read FVisible write FVisible; + property Font: TRoseDiagramFont read FFont write SetFont; + property MarkerColor: TColor read FMarkerColor write FMarkerColor; + property MarkerWidth: Byte read FMarkerWidth write FMarkerWidth; + property MarkerTransparency: Int100 read FMarkerTransparency write FMarkerTransparency; + end; + + TRoseDiagramAxes = class + private + FCaptionType: TAxesCaptionType; + FLine: TRoseDiagramLine; + FPercentageMarkers: TRoseDiagramAxisMarker; + FText: TRoseDiagramText; + procedure SetLine(AValue: TRoseDiagramLine); + procedure SetPercentageMarkers(AValue: TRoseDiagramAxisMarker); + procedure SetText(AValue: TRoseDiagramText); + public + constructor Create; + destructor Destroy; override; + + property Line: TRoseDiagramLine read FLine write SetLine; + property Text: TRoseDiagramText read FText write SetText; + property PercentageMarkers: TRoseDiagramAxisMarker read FPercentageMarkers write SetPercentageMarkers; + property CaptionType: TAxesCaptionType read FCaptionType write FCaptionType; + end; + + TRoseDiagramMetadata = class + private + FAuthor: string; + FDescription: string; + FSubject: string; + public + procedure SetProperties(const ASubject, AAuthor, ADescription: string); + + property Subject: string read FSubject write FSubject; + property Author: string read FAuthor write FAuthor; + property Description: string read FDescription write FDescription; + end; + + + TRoseDiagram = class + private + FAxes: TRoseDiagramAxes; + FCentralSymmetry: Boolean; + FDefaultMonoFontName: string; + FDefaultFontSize: Byte; + FDefaultFontColor: TColor; + FBackground: TRoseDiagramFill; + FCircles: TRoseDiagramLine; + FCirclesCount: Byte; + FDescription: TRoseDiagramText; + FDrawInternalPolygonLines: Boolean; + FMeasurementType: TMeasurementType; + FDiagramType: TRoseDiagramType; + FFrame: TRoseDiagramLine; + FMarginMM: integer; + FMetadata: TRoseDiagramMetadata; + FPieFill: TRoseDiagramFill; + FPieLine: TRoseDiagramLine; + FRadii: TRoseDiagramLine; + FRadiusMM: integer; + FSelectedBinFill: TRoseDiagramFill; + FSelectedBinLine: TRoseDiagramLine; + FBinDataList: TBinDataList; + FTitle: TRoseDiagramText; + function GetClassSize: Byte; + procedure SetAxes(AValue: TRoseDiagramAxes); + procedure SetCentralSymmetry(AValue: Boolean); + procedure SetBackground(AValue: TRoseDiagramFill); + procedure SetCircles(AValue: TRoseDiagramLine); + procedure SetCirclesCount(AValue: Byte); + procedure SetClassSize(AValue: Byte); + procedure SetDescription(AValue: TRoseDiagramText); + procedure SetFrame(AValue: TRoseDiagramLine); + procedure SetMarginMM(AValue: integer); + procedure SetMetadata(AValue: TRoseDiagramMetadata); + procedure SetPieFill(AValue: TRoseDiagramFill); + procedure SetPieLine(AValue: TRoseDiagramLine); + procedure SetRadii(AValue: TRoseDiagramLine); + procedure SetRadiusMM(AValue: integer); + procedure SetSelectedBinFill(AValue: TRoseDiagramFill); + procedure SetSelectedBinLine(AValue: TRoseDiagramLine); + procedure SetTitle(AValue: TRoseDiagramText); + protected + public + constructor Create; + destructor Destroy; override; + + procedure ResetToDefautParams; + + //////////// The main proc. ////////////////////////////// + procedure PaintOnCanvas(Canvas: TCanvas); + ////////////////////////////////////////////////////////// + + property ClassSize: Byte read GetClassSize write SetClassSize; + property BinDataList: TBinDataList read FBinDataList write FBinDataList; + property CentralSymmetry: Boolean read FCentralSymmetry write SetCentralSymmetry; + + property DiagramType: TRoseDiagramType read FDiagramType write FDiagramType; // Rose or polygon + property DrawInternalPolygonLines: Boolean read FDrawInternalPolygonLines write FDrawInternalPolygonLines; + property MeasurementType: TMeasurementType read FMeasurementType write FMeasurementType; + + property Background: TRoseDiagramFill read FBackground write SetBackground; + property Frame: TRoseDiagramLine read FFrame write SetFrame; + property Circles: TRoseDiagramLine read FCircles write SetCircles; + property CirclesCount: Byte read FCirclesCount write SetCirclesCount; + property Radii: TRoseDiagramLine read FRadii write SetRadii; + + property PieLine: TRoseDiagramLine read FPieLine write SetPieLine; + property PieFill: TRoseDiagramFill read FPieFill write SetPieFill; + + property Axes: TRoseDiagramAxes read FAxes write SetAxes; + + property SelectedBinLine: TRoseDiagramLine read FSelectedBinLine write SetSelectedBinLine; + property SelectedBinFill: TRoseDiagramFill read FSelectedBinFill write SetSelectedBinFill; + + property Title: TRoseDiagramText read FTitle write SetTitle; + property Description: TRoseDiagramText read FDescription write SetDescription; + + property RadiusMM: integer read FRadiusMM write SetRadiusMM; // Radius of the diagram [millimeters] + property MarginMM: integer read FMarginMM write SetMarginMM; // The space between the border (frame) and the diagram [millimeters] + + property Metadata: TRoseDiagramMetadata read FMetadata write SetMetadata; + end; + + + +{$region ' helpers '} +function TranspToAlpha(const TransparencyInPercent: Byte): Byte; +procedure CheckGPFontName(var AUserFontName: string; bMonospace: Boolean); +function RoseDiagramTypeToStrID(const DiagramType: TRoseDiagramType): string; +function StrIDToRoseDiagramType(StrID: string; Default: TRoseDiagramType = rdtRose): TRoseDiagramType; +function RoseMeasurementTypeToStrID(const mt: TMeasurementType): string; +function StrIDToRoseMeasurementType(StrID: string; Default: TMeasurementType = mt360): TMeasurementType; +function AxesCaptionTypeToStrID(const CaptionType: TAxesCaptionType): string; +function StrIDToAxesCaptionType(StrID: string; Default: TAxesCaptionType = actDegrees): TAxesCaptionType; +{$endregion helpers} + + +{$ENDIF} // MSWINDOWS + + +implementation + + +{$IFDEF MSWINDOWS} + +{$region ' helpers '} +function TranspToAlpha(const TransparencyInPercent: Byte): Byte; +begin + Result := TransparencyToAlpha(TransparencyInPercent); +end; + +procedure CheckGPFontName(var AUserFontName: string; bMonospace: Boolean); +begin + // W GDI+ próba zastosowania nieistniejącej czcionki kończy się błędem (exception). + // Dlatego należy się upewnić, że do funkcji GDI+ trafi nazwa istniejącej czcionki. + if bMonospace then + AUserFontName := string(GetGPFontName([UnicodeString(AUserFontName), 'Fira Mono', 'Roboto Mono', 'Consolas', 'Courier New', 'Tahoma'])) + // Tahoma - not monospaced but "safe" font + else + AUserFontName := string(GetGPFontName([UnicodeString(AUserFontName), 'Segoe UI', 'Tahoma'])); +end; + +function RoseDiagramTypeToStrID(const DiagramType: TRoseDiagramType): string; +begin + if DiagramType = rdtPolygon then Result := 'polygon' else Result := 'rose'; +end; + +function StrIDToRoseDiagramType(StrID: string; Default: TRoseDiagramType = rdtRose): TRoseDiagramType; +begin + StrID := TStr.TrimAndLow(StrID); + StrID := TSTr.TrimFromStart(StrID, 'rdt'); + if StrID = 'rose' then Result := rdtRose + else if StrID = 'polygon' then Result := rdtPolygon + else Result := Default; +end; + +function RoseMeasurementTypeToStrID(const mt: TMeasurementType): string; +begin + if mt = mt360 then Result := 'azimuths' else Result := 'linear'; +end; + +function StrIDToRoseMeasurementType(StrID: string; Default: TMeasurementType): TMeasurementType; +begin + StrID := TStr.TrimAndLow(StrID); + StrID := TStr.TrimFromStart(StrID, 'mt'); + StrID := TStr.ReplaceFirst(StrID, '360', 'azimuths'); + StrID := TStr.ReplaceFirst(StrID, '180', 'linear'); + if StrID = 'azimuths' then Result := mt360 + else if StrID = 'linear' then Result := mt180 + else Result := Default; +end; + +function AxesCaptionTypeToStrID(const CaptionType: TAxesCaptionType): string; +begin + case CaptionType of + actDegrees: Result := 'degrees'; + actSymbols: Result := 'symbols'; + else + Result := ''; + end; +end; + +function StrIDToAxesCaptionType(StrID: string; Default: TAxesCaptionType = actDegrees): TAxesCaptionType; +begin + StrID := TStr.TrimAndLow(StrID); + if StrID = 'degrees' then Result := actDegrees + else if StrID = 'symbols' then Result := actSymbols + else Result := Default; +end; + +{$endregion helpers} + + +{$region ' Create & Destroy '} +constructor TRoseDiagram.Create; +begin + inherited; + + FDiagramType := rdtRose; + FDrawInternalPolygonLines := True; + FMeasurementType := mt360; + + FBackground := TRoseDiagramFill.Create; + FFrame := TRoseDiagramLine.Create; + FCircles := TRoseDiagramLine.Create; + FRadii := TRoseDiagramLine.Create; + FPieLine := TRoseDiagramLine.Create; + FPieFill := TRoseDiagramFill.Create; + FAxes := TRoseDiagramAxes.Create; + FSelectedBinLine := TRoseDiagramLine.Create; + FSelectedBinFill := TRoseDiagramFill.Create; + FTitle := TRoseDiagramText.Create; + FDescription := TRoseDiagramText.Create; + + FBinDataList := TBinDataList.Create(10); + FMetadata := TRoseDiagramMetadata.Create; + + FDefaultMonoFontName := string(GetGPFontName(['Fira Mono', 'Roboto Mono', 'Consolas', 'Courier New', 'Tahoma'])); + FDefaultFontSize := 9; + FDefaultFontColor := clBlack; + + ResetToDefautParams; +end; + +destructor TRoseDiagram.Destroy; +begin + FBackground.Free; + FFrame.Free; + FCircles.Free; + FRadii.Free; + FPieLine.Free; + FPieFill.Free; + FAxes.Free; + FSelectedBinLine.Free; + FSelectedBinFill.Free; + FTitle.Free; + FDescription.Free; + + FBinDataList.ClearParams; + FBinDataList.Free; + + FMetadata.Free; + + inherited Destroy; +end; +{$endregion Create & Destroy} + +procedure TRoseDiagram.ResetToDefautParams; +begin + RadiusMM := 100; + MarginMM := 5; + + FBackground.SetProperties(clWhite, 0, HatchStyleDashedVertical, clWhite, True); + FFrame.SetProperties(False, clBlack, 0, 1, psSolid); + FCircles.SetProperties(True, clSilver, 0, 1, psDash); + FCirclesCount := 9; + FRadii.SetProperties(True, clSilver, 0, 1, psDash); + + FPieLine.SetProperties(True, 16748574, 0, 1.0, psSolid); + FPieFill.SetProperties(16436871, 40, HatchStyle30Percent, 16748574, False); + + FAxes.Line.SetProperties(True, clBlack, 0, 1, psSolid); + FAxes.Text.SetProperties(True, '', 'Verdana', 9, [], FDefaultFontColor, 0, 0, 0); + FAxes.PercentageMarkers.SetProperties(True, 'Verdana', 9, [], clBlack, 0, clBlack, 5, 0); + FAxes.CaptionType := actDegrees; + + FSelectedBinLine.SetProperties(True, clRed, 0, 1.0, psSolid); + FSelectedBinFill.SetProperties(RGB(255,160,122), 80, HatchStyle30Percent, clRed, True); + + FTitle.SetProperties(True, '', 'Verdana', 12, [FontStyleBold], clBlack, 3, 3, 0); + FDescription.SetProperties(True, '', 'Segoe UI', 10, [], clBlack, 3, 10, 0); + + FMetadata.Subject := ''; + FMetadata.Author := ''; + FMetadata.Description := ''; +end; + +{$region ' PaintOnCanvas '} +procedure TRoseDiagram.PaintOnCanvas(Canvas: TCanvas); +var + PixelConv: IPixelConv; + BinDataList: TBinDataList; + b180, b360, bSymm: Boolean; + gr: IGPGraphics; + Pen: IGPPen; + Brush: IGPBrush; + xWidth, xHeight, halfW, halfH, Margin, dx, dxm: Single; + i: integer; + RectF: TGPRectF; + FirstCircleRadius, CircleRadius: Single; + AngleStart, AngleSweep: Single; + + Points: array of TGPPointF; + APoint: TGPPointF; + + // variables used in drawing the radii + // px - X coordinate, py - Y coordinate + // AlphaAngle - angle: 90 - (i * ClassSize) + px, py, AlphaAngle, radius: Single; + + FontFamily: IGPFontFamily; + AFont: IGPFont; + Text: string; + TextWidth, TextHeight: Single; + + BinData: TBinData; + + RMaxPix, RBinPix: Single; + fi: Single; + + //Arr: TMeasurementArray; + + + function MmToPix(const xMillimeters: Single): Single; + begin + Result := PixelConv.MmToPixelsX(xMillimeters); + end; + +begin + if FRadiusMM <= 2 then Exit; + BinDataList := FBinDataList; + + b360 := FMeasurementType = mt360; + b180 := not b360; + bSymm := FCentralSymmetry and b180; + + PixelConv := TPixelConv.Create(Canvas); + //TPixelConv.Init(Canvas); // important! + + Margin := MmToPix(FMarginMM); + + if b360 or bSymm then + begin + xWidth := 2 * MmToPix(FRadiusMM) + (2 * Margin); + xHeight := xWidth; + end + else + // 180 + begin + xWidth := MmToPix(FRadiusMM) + 2 * Margin; + xHeight := 2 * MmToPix(FRadiusMM) + (2 * Margin); + end; + + halfW := xWidth / 2; + halfH := xHeight / 2; + + + gr := TGPGraphics.Create(Canvas.Handle); + gr.SmoothingMode := SmoothingModeHighQuality; + gr.PixelOffsetMode := PixelOffsetModeHighQuality; + + + {$region ' Background '} + Brush := TGPSolidBrush.Create(GPColor(FBackground.Color, TranspToAlpha(FBackground.Transparency))); + RectF.Initialize(0, 0, xWidth, xHeight); + gr.FillRectangle(Brush, RectF); + {$endregion} + + + {$region ' Frame '} + if FFRame.Visible then + begin + Pen := nil; + Pen := TGPPen.Create(GPColor(FFrame.Color, TranspToAlpha(FFrame.Transparency)), FFRame.Width); + SetGPPenStyle(Pen, FFrame.Style); + + // A slight correction is needed for the frame to display properly + dx := 0.5; + RectF.Initialize(dx, dx, xWidth - (2 * dx), xHeight - (2 * dx)); + + gr.DrawRectangle(Pen, RectF); + end; + {$endregion} + + + + // Transformation of the coordinate system + if b360 or bSymm then gr.TranslateTransform(halfW, halfH) // shifting the origin of the coordinate system to the center + else gr.TranslateTransform(Margin, halfH); + + gr.ScaleTransform(1, -1); // change of the Y axis direction (down to up) + + + {$region ' Circles '} + if (FCircles.Visible) and (FCirclesCount > 0) then + begin + Pen := nil; + Pen := TGPPen.Create(GPColor(FCircles.Color, TranspToAlpha(FCircles.Transparency)), FCircles.Width); + SetGPPenStyle(Pen, FCircles.Style); + Pen.StartCap := LineCapFlat; + Pen.EndCap := LineCapFlat; + + if b360 or bSymm then FirstCircleRadius := (halfW - Margin) / FCirclesCount + else FirstCircleRadius := (xWidth - 2 * Margin) / FCirclesCount; + + for i := 1 to FCirclesCount do + begin + CircleRadius := i * FirstCircleRadius; + RectF.X := -CircleRadius; + RectF.Y := -CircleRadius; + RectF.Width := 2 * CircleRadius; + RectF.Height := 2 * CircleRadius; + if b360 or bSymm then gr.DrawEllipse(Pen, RectF) // full circle + else {if b180 then} gr.DrawPie(Pen, RectF, -90, 180); // half circle // dla linii biegu + end; + end; + {$endregion} + + + {$region ' Radii '} + if FRadii.Visible then + begin + + Pen := nil; + Pen := TGPPen.Create(GPColor(FRadii.Color, TranspToAlpha(FRadii.Transparency)), FRadii.Width); + SetGPPenStyle(Pen, FRadii.Style); + Pen.StartCap := LineCapFlat; + Pen.EndCap := LineCapFlat; + + if b360 or bSymm then radius := halfW - Margin + else radius := xWidth - 2 * Margin; + + for i := 1 to BinDataList.Count do + begin + BinData := BinDataList[i - 1]; + AlphaAngle := 90 - (i * BinDataList.ClassSize); + + px := radius * CosDeg(AlphaAngle); + py := radius * SinDeg(AlphaAngle); + gr.DrawLine(Pen, 0, 0, px, py); + + // Kreślenie promieni w ćwiartce II i IV dla symetrycznych diagramów biegu + if bSymm then + begin + px := radius * CosDeg(AlphaAngle + 180); + py := radius * SinDeg(AlphaAngle + 180); + gr.DrawLine(Pen, 0, 0, px, py); + end; + end; + + end; + {$endregion} + + + {$region ' Pies / Polygon'} + if (BinDataList.Count > 0) and (BinDataList.Stats.MaxMeasurementsInBin > 0) then + begin + + gr.ResetTransform; + if b360 or bSymm then gr.TranslateTransform(halfW, halfH) + else gr.TranslateTransform(Margin, halfH); + + //gr.ScaleTransform(1, -1); + gr.RotateTransform(-90); // 0 degrees at the top + + Pen := nil; + Pen := TGPPen.Create(GPColor(FPieLine.Color, TranspToAlpha(FPieLine.Transparency)), FPieLine.Width); + SetGPPenStyle(Pen, FPieLine.Style); + + Brush := nil; + if FPieFill.SolidFill then + Brush := TGPSolidBrush.Create(GPColor(FPieFill.Color, TranspToAlpha(FPieFill.Transparency))) + else + Brush := TGPHatchBrush.Create( + FPieFill.FHatchStyle, + GPColor(FPieFill.HatchColor, TranspToAlpha(FPieFill.Transparency)), + GPColor(FPieFill.Color, TranspToAlpha(FPieFill.Transparency)) + ); + + + {$region ' Pies - "classic" rose diagram (wedges) '} + if FDiagramType = rdtRose then + for i := 0 to BinDataList.Count - 1 do + begin + BinData := BinDataList[i]; + if b180 and (not bSymm) and (BinData.StartValue >= 180) then Continue; + if BinData.MeasurementCount = 0 then Continue; + + if b360 or bSymm then dx := (halfW - Margin) * BinData.MeasurementCount / BinDataList.Stats.MaxMeasurementsInBin + else dx := (xWidth - 2 * Margin) * BinData.MeasurementCount / BinDataList.Stats.MaxMeasurementsInBin; + + RectF.X := -dx; + RectF.Y := -dx; + RectF.Width := 2 * dx; + RectF.Height := RectF.Width; + AngleStart := BinData.StartValue; + AngleSweep := BinDataList.ClassSize; + + gr.DrawPie(Pen, RectF, AngleStart, AngleSweep); + gr.FillPie(Brush, RectF, AngleStart, AngleSweep); + + if bSymm then + begin + dx := (halfW - Margin) * BinData.MeasurementCount / BinDataList.Stats.MaxMeasurementsInBin; + + RectF.X := -dx; + RectF.Y := -dx; + RectF.Width := 2 * dx; + RectF.Height := RectF.Width; + AngleStart := BinData.StartValue; + AngleSweep := BinDataList.ClassSize; + + gr.DrawPie(Pen, RectF, AngleStart - 180, AngleSweep); + gr.FillPie(Brush, RectF, AngleStart - 180, AngleSweep); + end; + + end; + {$endregion Pies} + + + + {$region ' Polygon '} + if FDiagramType = rdtPolygon then + begin + gr.ResetTransform; + if b360 or bSymm then gr.TranslateTransform(halfW, halfH) + else gr.TranslateTransform(Margin, halfH); + gr.ScaleTransform(1, -1); + + SetLength(Points{%H-}, 0); + if b360 or bSymm then RMaxPix := halfW - Margin + else RMaxPix := xWidth - 2 * Margin; + + + // Tworzenie tablicy punktów wielokąta (polygon) + // Create an array with a list of polygon points + for i := 0 to BinDataList.Count - 1 do + begin + BinData := BinDataList[i]; + if b180 and (not bSymm) and (BinData.StartValue >= 180) then Continue; + + if BinData.MeasurementCount = 0 then + begin + SetLength(Points, Length(Points) + 1); + Points[High(Points)] := GPPointF(0, 0); + Continue; + end; + + // I use the polar coordinate system with the fi angle. + // Calculation of Cartesian coordinates: px and py. + RBinPix := RMaxPix * BinData.MeasurementCount / BinDataList.Stats.MaxMeasurementsInBin; + fi := 90 - BinData.EndValue + (ClassSize / 2); + px := RBinPix * CosDeg(fi); + py := RBinPix * SinDeg(fi); + + // If there is no measurement in the first interval (empty), it adds a point (0,0) to the beginning of the Points table. + // Thanks to this, the polygon will be "hooked" to the origin of the coordinate system. + if b180 {and (not bSymm)} and (i = 0) and (BinData.MeasurementCount > 0) then + begin + SetLength(Points, Length(Points) + 1); + Points[High(Points)] := GPPointF(0, 0); + end; + + SetLength(Points, Length(Points) + 1); + Points[High(Points)] := GPPointF(px, py); + end; + + gr.FillPolygon(Brush, Points); + gr.DrawPolygon(Pen, Points); + + if FDrawInternalPolygonLines then + // The inner lines of the polygon + // It is important not to plot the lines already drawn by calling gr.DrawPolygon earlier. + // If this happens, the non-solid lines (dashed, dotted, etc.) will overlap and "form" a solid line. + for i := 0 to High(Points) do + begin + APoint := Points[i]; + if (APoint.X = 0) and (APoint.Y = 0) then Continue; + + if i > 0 then + if (Points[i - 1].X = 0) and (Points[i - 1].Y = 0) then Continue; + + if i < High(Points) then + if (Points[i + 1].X = 0) and (Points[i + 1].Y = 0) then Continue; + + gr.DrawLine(Pen, GPPointF(0, 0), APoint); + end; + + + + if bSymm then + begin + + SetLength(Points, 0); + for i := 0 to BinDataList.Count - 1 do + begin + BinData := BinDataList[i]; + + if BinData.MeasurementCount = 0 then + begin + SetLength(Points, Length(Points) + 1); + Points[High(Points)] := GPPointF(0, 0); + Continue; + end; + + RBinPix := RMaxPix * BinData.MeasurementCount / BinDataList.Stats.MaxMeasurementsInBin; + fi := 270 - BinData.EndValue + (ClassSize / 2); + px := RBinPix * CosDeg(fi); + py := RBinPix * SinDeg(fi); + + if (i = 0) and (BinData.MeasurementCount > 0) then + begin + SetLength(Points, Length(Points) + 1); + Points[High(Points)] := GPPointF(0, 0); + end; + + SetLength(Points, Length(Points) + 1); + Points[High(Points)] := GPPointF(px, py); + end; + + gr.FillPolygon(Brush, Points); + gr.DrawPolygon(Pen, Points); + + if FDrawInternalPolygonLines then + for i := 0 to High(Points) do + begin + APoint := Points[i]; + if (APoint.X = 0) and (APoint.Y = 0) then Continue; + + if i > 0 then + if (Points[i - 1].X = 0) and (Points[i - 1].Y = 0) then Continue; + + if i < High(Points) then + if (Points[i + 1].X = 0) and (Points[i + 1].Y = 0) then Continue; + + gr.DrawLine(Pen, GPPointF(0, 0), APoint); + end; + + end; // bSymm + + + end; + {$endregion Polygon} + + end; + {$endregion Pies / Polygon} + + + {$region ' Selected bins '} + if BinDataList.SelectedBinsCount > 0 then + begin + gr.ResetTransform; + if b360 or bSymm then gr.TranslateTransform(halfW, halfH) + else gr.TranslateTransform(Margin, halfH); + gr.RotateTransform(-90); + + Pen := nil; + Pen := TGPPen.Create(GPColor(FSelectedBinLine.Color, TranspToAlpha(FSelectedBinLine.Transparency)), FSelectedBinLine.Width); + SetGPPenStyle(Pen, FSelectedBinLine.Style); + if b360 or bSymm then dx := halfW - Margin + else dx := xWidth - 2 * Margin; + + Brush := nil; + if FSelectedBinFill.SolidFill then + Brush := TGPSolidBrush.Create(GPColor(FSelectedBinFill.Color, TranspToAlpha(FSelectedBinFill.Transparency))) + else + Brush := TGPHatchBrush.Create( + FSelectedBinFill.FHatchStyle, + GPColor(FSelectedBinFill.HatchColor, TranspToAlpha(FSelectedBinFill.Transparency)), + GPColor(FSelectedBinFill.Color, TranspToAlpha(FSelectedBinFill.Transparency)) + ); + + for i := 0 to BinDataList.Count - 1 do + begin + BinData := BinDataList[i]; + if b180 and (not bSymm) and (BinData.StartValue >= 180) then Continue; + if not BinData.Selected then Continue; + + RectF.X := -dx; + RectF.Y := -dx; + RectF.Width := 2 * dx; + RectF.Height := RectF.Width; + AngleStart := BinData.StartValue; + AngleSweep := BinDataList.ClassSize; + + gr.DrawPie(Pen, RectF, AngleStart, AngleSweep); + gr.FillPie(Brush, RectF, AngleStart, AngleSweep); + end; + end; + {$endregion Selected bins} + + + {$region ' Axes '} + gr.ResetTransform; + + {$region ' Axis X and Y - Lines '} + if FAxes.Line.Visible then + begin + Pen := nil; + Pen := TGPPen.Create(GPColor(FAxes.Line.Color, TranspToAlpha(FAxes.Line.Transparency)), FAxes.Line.Width); + SetGPPenStyle(Pen, FAxes.Line.Style); + Pen.StartCap := LineCapFlat; + Pen.EndCap := LineCapArrowAnchor; + + if b360 or bSymm then + begin + gr.DrawLine(Pen, 0, halfH, xWidth, halfH); // X + gr.DrawLine(Pen, halfW, xHeight, halfW, 0); // Y + end + else + begin + gr.DrawLine(Pen, 0, halfH, xWidth, halfH); // X + gr.DrawLine(Pen, Margin, xHeight, Margin, 0); // Y + end; + end; + {$endregion Axis X and Y - Lines} + + + {$region ' Axis X and Y - Captions '} + if FAxes.Text.Visible then + begin + FontFamily := nil; + AFont := nil; + Brush := nil; + + try + FontFamily := TGPFontFamily.Create(UnicodeString(FAxes.Text.Font.FontName)); + except + FontFamily := TGPFontFamily.Create(UnicodeString('Tahoma')); + end; + + AFont := TGPFont.Create(FontFamily, FAxes.Text.Font.Size, FAxes.Text.Font.Style, TGPUnit.UnitPoint); + Brush := TGPSolidBrush.Create(GPColor(FAxes.Text.Font.Color, TranspToAlpha(FAxes.Text.Font.Transparency))); + + + if FAxes.CaptionType = actSymbols then Text := 'N' else Text := '0' + DEG_SIGN; + //px := halfW; + if FAxes.Line.Visible then + begin + if b360 or bSymm then px := halfW + 1 + else px := Margin + 1; + end + else + begin + TextWidth := GPTextWidthF(gr, UnicodeString(Text), AFont); + if b360 or bSymm then px := halfW - (TextWidth / 2) + else px := Margin - (TextWidth / 2); + end; + gr.DrawString(UnicodeString(Text), AFont, TGPPointF.Create(px, 1), Brush); + + + if FAxes.CaptionType = actSymbols then Text := 'E' else Text := '90' + DEG_SIGN; + TextWidth := GPTextWidthF(gr, UnicodeString(Text), AFont); + TextHeight := GPTextHeightF(gr, UnicodeString(Text), AFont); + if FAxes.Line.Visible then py := halfH - TextHeight + else py := halfH - (TextHeight / 2); + gr.DrawString(UnicodeString(Text), AFont, TGPPointF.Create(xWidth - TextWidth - 1, py), Brush); + + + if FAxes.CaptionType = actSymbols then Text := 'S' else Text := '180' + DEG_SIGN; + TextHeight := GPTextHeightF(gr, UnicodeString(Text), AFont); + if FAxes.Line.Visible then + begin + if b360 or bSymm then px := halfW + 1 + else px := Margin + 1; + end + else + begin + TextWidth := GPTextWidthF(gr, UnicodeString(Text), AFont); + if b360 or bSymm then px := halfW - (TextWidth / 2) + else px := Margin - (TextWidth / 2); + end; + gr.DrawString(UnicodeString(Text), AFont, TGPPointF.Create(px, xHeight - TextHeight - 1), Brush); + + if b360 or bSymm then + begin + if FAxes.CaptionType = actSymbols then Text := 'W' else Text := '270' + DEG_SIGN; + TextHeight := GPTextHeightF(gr, UnicodeString(Text), AFont); + if FAxes.Line.Visible then py := halfH - TextHeight + else py := halfH - (TextHeight / 2); + gr.DrawString(UnicodeString(Text), AFont, TGPPointF.Create(1, py), Brush); + end; + end; + {$endregion Axis X and Y - Captions} + + + {$region ' Axis X - Percentage markers (ticks) '} + if FAxes.PercentageMarkers.Visible then + if FBinDataList.Stats.MaxMeasurementsInBin_Percentage > 0 then + begin + + FontFamily := nil; + AFont := nil; + Brush := nil; + Pen := nil; + + try + FontFamily := TGPFontFamily.Create(UnicodeString(FAxes.PercentageMarkers.Font.FontName)); + except + FontFamily := TGPFontFamily.Create(UnicodeString('Tahoma')); + end; + + AFont := TGPFont.Create(FontFamily, FAxes.PercentageMarkers.Font.Size, FAxes.PercentageMarkers.Font.Style, TGPUnit.UnitPoint); + Brush := TGPSolidBrush.Create(GPColor(FAxes.PercentageMarkers.Font.Color, TranspToAlpha(FAxes.PercentageMarkers.Font.Transparency))); + + Pen := TGPPen.Create(GPColor(FAxes.PercentageMarkers.MarkerColor, TranspToAlpha(FAxes.PercentageMarkers.MarkerTransparency)), 1.5); + SetGPPenStyle(Pen, psSolid); + Pen.StartCap := LineCapFlat; + Pen.EndCap := LineCapFlat; + + py := halfH; + CircleRadius := MmToPix(RadiusMM); + dx := CircleRadius / FBinDataList.Stats.MaxMeasurementsInBin_Percentage; // dx = 1 percent in pix + dxm := FAxes.PercentageMarkers.MarkerWidth / 2; // połowa długości znacznika + + + // px - współrz. X-owa znacznika + // py - współrz. Y-owa znacznika + + if b360 or bSymm then px := HalfW else px := Margin; + for i := 1 to 100 do + begin + if i > FBinDataList.Stats.MaxMeasurementsInBin_Percentage then Break; + py := py - dx; + gr.DrawLine(Pen, px - dxm, py, px + dxm, py); + Text := itos(i) + '%'; + TextHeight := GPTextHeightF(gr, UnicodeString(Text), AFont); + gr.DrawString(UnicodeString(Text), AFont, TGPPointF.Create(px + dxm + 1, py - (TextHeight / 2)), Brush); + end; + + end; + {$endregion Axis X - Percentage markers (ticks)} + + {$endregion Axes} + + + {$region ' Title & description '} + + // Title + if FTitle.Visible and (FTitle.Text <> '') then + begin + gr.ResetTransform; + + FontFamily := nil; + FontFamily := TGPFontFamily.Create(GetGPFontName([UnicodeString(FTitle.Font.FontName), 'Segoe UI', 'Tahoma'])); + AFont := nil; + AFont := TGPFont.Create(FontFamily, FTitle.Font.Size, FTitle.Font.Style, TGPUnit.UnitPoint); + Brush := nil; + Brush := TGPSolidBrush.Create(GPColor(FTitle.Font.Color, TranspToAlpha(FTitle.Font.Transparency))); + Text := FTitle.Text; + px := MmToPix(FTitle.PosX); + py := MmToPix(FTitle.PosY); + gr.DrawString(UnicodeString(Text), AFont, TGPPointF.Create(px, py), Brush); + end; + + // Description + if FDescription.Visible and (FDescription.Text <> '') then + begin + gr.ResetTransform; + + FontFamily := nil; + FontFamily := TGPFontFamily.Create(GetGPFontName([UnicodeString(FDescription.Font.FontName), 'Segoe UI', 'Tahoma'])); + AFont := nil; + AFont := TGPFont.Create(FontFamily, FDescription.Font.Size, FDescription.Font.Style, TGPUnit.UnitPoint); + Brush := nil; + Brush := TGPSolidBrush.Create(GPColor(FDescription.Font.Color, TranspToAlpha(FDescription.Font.Transparency))); + Text := FDescription.Text; + px := MmToPix(FDescription.PosX); + py := MmToPix(FDescription.PosY); + gr.DrawString(UnicodeString(Text), AFont, TGPPointF.Create(px, py), Brush); + end; + + {$endregion Title & description} + + +end; +{$endregion PaintOnCanvas} + +procedure TRoseDiagram.SetBackground(AValue: TRoseDiagramFill); +begin + if FBackground = AValue then Exit; + FBackground := AValue; +end; + +procedure TRoseDiagram.SetCircles(AValue: TRoseDiagramLine); +begin + if FCircles = AValue then Exit; + FCircles := AValue; +end; + +procedure TRoseDiagram.SetCirclesCount(AValue: Byte); +begin + if FCirclesCount = AValue then Exit; + FCirclesCount := AValue; +end; + +procedure TRoseDiagram.SetClassSize(AValue: Byte); +begin + if FBinDataList.ClassSize = AValue then Exit; + FBinDataList.ClassSize := AValue; +end; + +procedure TRoseDiagram.SetDescription(AValue: TRoseDiagramText); +begin + if FDescription = AValue then Exit; + FDescription := AValue; +end; + +procedure TRoseDiagram.SetFrame(AValue: TRoseDiagramLine); +begin + if FFrame = AValue then Exit; + FFrame := AValue; +end; + +function TRoseDiagram.GetClassSize: Byte; +begin + Result := FBinDataList.ClassSize; +end; + +procedure TRoseDiagram.SetAxes(AValue: TRoseDiagramAxes); +begin + if FAxes = AValue then Exit; + FAxes := AValue; +end; + +procedure TRoseDiagram.SetCentralSymmetry(AValue: Boolean); +begin + if FCentralSymmetry = AValue then Exit; + FCentralSymmetry := AValue; +end; + +procedure TRoseDiagram.SetMarginMM(AValue: integer); +begin + if FMarginMM = AValue then Exit; + + // The sum of the margins must be smaller than the width of the entire diagram. + // Suma marginesów musi mniejsza od szerokości całego diagramu. + if (AValue * 2) >= FRadiusMM then AValue := (FRadiusMM div 2) - 1; + + FMarginMM := AValue; +end; + +procedure TRoseDiagram.SetMetadata(AValue: TRoseDiagramMetadata); +begin + if FMetadata = AValue then Exit; + FMetadata := AValue; +end; + +procedure TRoseDiagram.SetPieFill(AValue: TRoseDiagramFill); +begin + if FPieFill = AValue then Exit; + FPieFill := AValue; +end; + +procedure TRoseDiagram.SetPieLine(AValue: TRoseDiagramLine); +begin + if FPieLine = AValue then Exit; + FPieLine := AValue; +end; + +procedure TRoseDiagram.SetRadii(AValue: TRoseDiagramLine); +begin + if FRadii = AValue then Exit; + FRadii := AValue; +end; + +procedure TRoseDiagram.SetRadiusMM(AValue: integer); +begin + if AValue <= 0 then AValue := 10; // must be greather than 0 + if FRadiusMM = AValue then Exit; + FRadiusMM := AValue; +end; + +procedure TRoseDiagram.SetSelectedBinFill(AValue: TRoseDiagramFill); +begin + if FSelectedBinFill = AValue then Exit; + FSelectedBinFill := AValue; +end; + +procedure TRoseDiagram.SetSelectedBinLine(AValue: TRoseDiagramLine); +begin + if FSelectedBinLine = AValue then Exit; + FSelectedBinLine := AValue; +end; + +procedure TRoseDiagram.SetTitle(AValue: TRoseDiagramText); +begin + if FTitle = AValue then Exit; + FTitle := AValue; +end; + + + +{ TRoseDiagramLine } + +procedure TRoseDiagramLine.SetProperties + (const AVisible: Boolean; const AColor: TColor; const ATransparency: Int100; const AWidth: Single; const AStyle: TPenStyle); +begin + FVisible := AVisible; + FColor := AColor; + FTransparency := ATransparency; + FWidth := AWidth; + FStyle := AStyle; +end; + + + +{ TRoseDiagramFill } + +procedure TRoseDiagramFill.SetProperties + (const AColor: TColor; const ATransparency: Int100; const AHatchStyle: TGPHatchStyle; const AHatchColor: TColor; const ASolidFill: Boolean); +begin + FColor := AColor; + FTransparency := ATransparency; + FHatchStyle := AHatchStyle; + FHatchColor := AHatchColor; + FSolidFill := ASolidFill; +end; + + + +{ TRoseDiagramFont } + +procedure TRoseDiagramFont.SetProperties(const AFontName: string; const ASize: Byte; const AStyle: TGPFontStyle; const AColor: TColor; + const ATransparency: Int100); +begin + FFontName := AFontName; + FSize := ASize; + FStyle := AStyle; + FColor := AColor; + FTransparency := ATransparency; +end; + +procedure TRoseDiagramFont.Assign(AFont: TRoseDiagramFont); +begin + SetProperties(AFont.FontName, AFont.Size, AFont.Style, AFont.Color, AFont.Transparency); +end; + +procedure TRoseDiagramFont.SetFontName(AValue: string); +begin + if FFontName = AValue then Exit; + CheckGPFontName(AValue, True); // check if font exists + FFontName := AValue; +end; + + +{ TRoseDiagramText } + +constructor TRoseDiagramText.Create; +begin + inherited Create; + FFont := TRoseDiagramFont.Create; +end; + +destructor TRoseDiagramText.Destroy; +begin + FFont.Free; + inherited Destroy; +end; + +procedure TRoseDiagramText.SetProperties(const AVisible: Boolean; const AText, AFontName: string; const AFontSizePt: Byte; + const AFontStyle: TGPFontStyle; const AFontColor: TColor; const APosX, APosY: Single; const AFontTransparency: Int100); +begin + FVisible := AVisible; + FText := AText; + FFont.SetProperties(AFontName, AFontSizePt, AFontStyle, AFontColor, AFontTransparency); + FPosX := APosX; + FPosY := APosY; +end; + +procedure TRoseDiagramText.SetFont(AValue: TRoseDiagramFont); +begin + FFont.Assign(AValue); +end; + + + +{ TRoseDiagramAxisMarker } + +constructor TRoseDiagramAxisMarker.Create; +begin + inherited Create; + FFont := TRoseDiagramFont.Create; +end; + +destructor TRoseDiagramAxisMarker.Destroy; +begin + FFont.Free; + inherited Destroy; +end; + +procedure TRoseDiagramAxisMarker.SetProperties(const AVisible: Boolean; const AFontName: string; const AFontSizePt: Byte; + const AFontStyle: TGPFontStyle; const AFontColor: TColor; const AFontTransparency: Int100; const AMarkerColor: TColor; const AMarkerWidth: Byte; + const AMarkerTransparency: Int100); +begin + FVisible := AVisible; + FFont.SetProperties(AFontName, AFontSizePt, AFontStyle, AFontColor, AFontTransparency); + FMarkerColor := AMarkerColor; + FMarkerWidth := AMarkerWidth; + FMarkerTransparency := AMarkerTransparency; +end; + +procedure TRoseDiagramAxisMarker.SetFont(AValue: TRoseDiagramFont); +begin + FFont.Assign(AValue); +end; + + + +{ TRoseDiagramAxes } + +constructor TRoseDiagramAxes.Create; +begin + inherited; + FLine := TRoseDiagramLine.Create; + FText := TRoseDiagramText.Create; + FPercentageMarkers := TRoseDiagramAxisMarker.Create; +end; + +destructor TRoseDiagramAxes.Destroy; +begin + FLine.Free; + FText.Free; + FPercentageMarkers.Free; + inherited Destroy; +end; + +procedure TRoseDiagramAxes.SetLine(AValue: TRoseDiagramLine); +begin + if FLine = AValue then Exit; + FLine := AValue; +end; + +procedure TRoseDiagramAxes.SetPercentageMarkers(AValue: TRoseDiagramAxisMarker); +begin + if FPercentageMarkers = AValue then Exit; + FPercentageMarkers := AValue; +end; + +procedure TRoseDiagramAxes.SetText(AValue: TRoseDiagramText); +begin + if FText = AValue then Exit; + FText := AValue; +end; + + + +{ TRoseDiagramMetadata } + +procedure TRoseDiagramMetadata.SetProperties(const ASubject, AAuthor, ADescription: string); +begin + FSubject := ASubject; + FAuthor := AAuthor; + FDescription := ADescription; +end; + +{$ENDIF} + + +end. +