|
Фильтрация, регрессия, работа с массивом и серией
Автор: Lookin
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Фильтрация, регрессия, работа с массивом и серией
Модуль предназначен для выполнения процедур:
- фильтрации
- регрессии
- операций с массивами
- операций с сериями
Зависимости: Math, TeEngine, Graphics, SysUtils, Dialogs
Автор: lookin, lookin@mail.ru, Екатеринбург
Copyright: lookin
Дата: 30 апреля 2002 г.
***************************************************** }
unit FilterRegressionArraySeries;
interface
uses Math, TeEngine, Graphics, SysUtils, Dialogs;
type
TIntegerArray = array of integer;
type
TExIntegerArray = array of TIntegerArray;
type
TDoubleArray = array of double;
type
TExDoubleArray = array of TDoubleArray;
type
TStringArray = array of string;
type
TExStringArray = array of TStringArray;
procedure ArrayExpanding(var ValueArray: TDoubleArray; ExpandCoef: integer);
procedure ArrayLengthening(var ValueArray: TDoubleArray; SplitValue: integer);
procedure ArrayShortening(var ValueArray: TDoubleArray; SplitValue: integer);
procedure CubicSplineSmoothing(var ValueArray: TDoubleArray; Dsc: double;
Coef: integer);
procedure SevenPointNonLinearSmoothing(var ValueArray: TDoubleArray;
Dsc: double; Coef: integer);
procedure FourierAnalysis(var ValueArray: TDoubleArray; NumGarmonics: integer);
procedure DoArraySmoothing(var ValueArray: TDoubleArray; FilterType: integer;
Dsc: double; SplitCoef, ExpandCoef: integer;
CycledFilter: boolean);
procedure LinearRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries;
var MainCoef, FreeCoef: double; SeriesColor: TColor;
var Hint: string);
procedure HyperbolicRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries;
var MainCoef, FreeCoef: double;
SeriesColor: TColor; var Hint: string);
procedure PowerRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries;
var MainCoef, FreeCoef: double; SeriesColor: TColor;
var Hint: string);
procedure PolynomialRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries;
PolyDegree: integer; var ArrayCoefs: TDoubleArray;
SeriesColor: TColor; var Hint: string);
procedure ExponentRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries;
var MainCoef, FreeCoef: double; SeriesColor: TColor;
var Hint: string; Warning: boolean);
procedure ExponentialRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries;
var MainCoef, FreeCoef: double; SeriesColor: TColor;
var Hint: string; Warning: boolean);
procedure ExpPowerRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries;
var MainCoef, FreeCoef: double; SeriesColor: TColor;
var Hint: string; Warning: boolean);
procedure CheckArrayBounds(var CArray: TDoubleArray; var FromPoint, ToPoint:
integer);
procedure CheckSeriesBounds(CSeries: TChartSeries; var FromPoint, ToPoint:
integer);
procedure ArrayFromArray(var SourceArray, DestArray: TDoubleArray;
FromPoint, ToPoint, Discrete: integer; Derivative: boolean);
procedure ArrayFromSeries(var ValueArray: TDoubleArray; DataSeries:
TChartSeries;
FromPoint, ToPoint, Discrete: integer; Derivative: boolean);
procedure SeriesFromArray(var ValueArray: TDoubleArray; DataSeries:
TChartSeries;
FromPoint, ToPoint, Discrete: integer; Derivative: boolean);
function DerivFromArray(var SourceArray: TDoubleArray; FromPoint, ToPoint,
Discrete: integer; Extremum: string;
var Position: integer): double;
function DerivFromSeries(DataSeries: TChartSeries; FromPoint, ToPoint,
Discrete: integer; Extremum: string;
var Position: integer): double;
function ValueFromSeries(DataSeries: TChartSeries; FromPoint, ToPoint: integer;
Extremum: string; var Position: integer): double;
function ValueFromArray(var SourceArray: TDoubleArray; FromPoint, ToPoint:
integer;
Extremum: string; var Position: integer): double;
function CalculateAreaOfArray(var SourceArray: TDoubleArray;
FromPoint, ToPoint, Method: integer;
BindToZero: boolean): double;
function CalculateAreaOfSeries(DataSeries: TChartSeries; FromPoint, ToPoint,
Method: integer; BindToZero: boolean): double;
procedure LinearTrendExclusion(var ValueArray: TDoubleArray);
procedure ColorizeSeries(DataSeries: TChartSeries; NewColor: TColor);
procedure SetXInterval(DataSeries: TChartSeries; XInterval: double);
procedure SetSeriesAxis(DataSeries: TChartSeries; NewAxis: TVertAxis);
var
rv, rsmooth, smootha: TDoubleArray;
implementation
//Нелинейный фильтр по 7 точкам
procedure SevenPointNonLinearSmoothing(var ValueArray: TDoubleArray;
Dsc: double; Coef: integer);
var
j, k, i: integer;
resv: array of array of double;
begin
if (Coef = 0) or (Coef = 1) then
Exit;
SetLength(resv, Coef, (Length(ValueArray) div Coef));
for j := 0 to Coef - 1 do
for i := 0 to Length(resv[0]) - 1 do
resv[j][i] := ValueArray[i * Coef + j];
for k := 0 to Coef - 1 do
for j := 0 to Length(resv[0]) - 1 do
begin
if j = 0 then
resv[k][j] := (39 * ValueArray[j * Coef + k] +
8 * ValueArray[(j + 1) * Coef + k] - 4 * (ValueArray[(j + 2) * Coef +
k] +
ValueArray[(j + 3) * Coef + k] - ValueArray[(j + 4) * Coef + k]) +
ValueArray[(j + 5) * Coef + k] - 2 * ValueArray[(j + 6) * Coef + k]) /
42;
if j = 1 then
resv[k][j] := (8 * ValueArray[j * Coef + k] +
19 * ValueArray[(j + 1) * Coef + k] + 16 * ValueArray[(j + 2) * Coef +
k] +
6 * ValueArray[(j + 3) * Coef + k] - 4 * ValueArray[(j + 4) * Coef + k]
-
7 * ValueArray[(j + 5) * Coef + k] + 4 * ValueArray[(j + 6) * Coef +
k]) / 42;
if j = 2 then
resv[k][j] := (-4 * ValueArray[j * Coef + k] +
16 * ValueArray[(j + 1) * Coef + k] + 19 * ValueArray[(j + 2) * Coef +
k] +
12 * ValueArray[(j + 3) * Coef + k] + 2 * ValueArray[(j + 4) * Coef +
k] -
4 * ValueArray[(j + 5) * Coef + k] + ValueArray[(j + 6) * Coef + k]) /
42;
if (j > 2) and (j < Length(resv[0]) - 3) then
resv[k][j] :=
(7 * ValueArray[j * Coef + k] + 6 * (ValueArray[(j - 1) * Coef + k] +
ValueArray[(j + 1) * Coef + k]) + 3 * (ValueArray[(j - 2) * Coef + k]
+
ValueArray[(j + 2) * Coef + k]) - 2 * (ValueArray[(j - 3) * Coef + k]
+
ValueArray[(j + 3) * Coef + k])) / 21;
if j = Length(resv[0]) - 3 then
resv[k][j] := (-4 * ValueArray[j * Coef + k] +
16 * ValueArray[(j - 1) * Coef + k] + 19 * ValueArray[(j - 2) * Coef +
k] +
12 * ValueArray[(j - 3) * Coef + k] + 2 * ValueArray[(j - 4) * Coef +
k] -
4 * ValueArray[(j - 5) * Coef + k] + ValueArray[(j - 6) * Coef + k]) /
42;
if j = Length(resv[0]) - 2 then
resv[k][j] := (8 * ValueArray[j * Coef + k] +
19 * ValueArray[(j - 1) * Coef + k] + 16 * ValueArray[(j - 2) * Coef +
k] +
6 * ValueArray[(j - 3) * Coef + k] - 4 * ValueArray[(j - 4) * Coef + k]
-
7 * ValueArray[(j - 5) * Coef + k] + 4 * ValueArray[(j - 6) * Coef +
k]) / 42;
if j = Length(resv[0]) - 1 then
resv[k][j] := (39 * ValueArray[j * Coef + k] +
8 * ValueArray[(j - 1) * Coef + k] - 4 * ValueArray[(j - 2) * Coef + k]
-
4 * ValueArray[(j - 3) * Coef + k] - 4 * ValueArray[(j - 4) * Coef + k]
+
ValueArray[(j - 5) * Coef + k] - 2 * ValueArray[(j - 6) * Coef + k]) /
42;
end;
for j := Coef to Length(resv[0]) - Coef do
for k := 0 to Coef - 1 do
ValueArray[j * Coef + k] := resv[k][j];
end;
//Фильтр с кубическими сплайнами
procedure CubicSplineSmoothing(var ValueArray: TDoubleArray; Dsc: double;
Coef: integer);
var
j, k, i, N: integer;
vresv, resv: array of array of double;
maxv: array of double;
av, h, mi, mj, v1, v2: double;
begin
if (Coef = 0) or (Coef = 1) then
Exit;
N := Length(ValueArray);
SetLength(resv, Coef, N);
h := Coef * Dsc;
for k := 0 to Coef - 1 do
for j := 0 to (N div Coef) - 2 do
begin
if j = 0 then
begin
mi := (4 * ValueArray[(j + 1) * Coef + k] -
ValueArray[(j + 2) * Coef + k] - 3 * ValueArray[j * Coef + k]) / 2;
mj := (ValueArray[(j + 2) * Coef + k] - ValueArray[j * Coef + k]) / 2;
end;
if j = (N div Coef) - 2 then
begin
mi := (ValueArray[(j + 1) * Coef + k] - ValueArray[(j - 1) * Coef + k])
/ 2;
mj := (3 * ValueArray[(j + 1) * Coef + k] + ValueArray[(j - 1) * Coef +
k] -
4 * ValueArray[j * Coef + k]) / 2;
end;
if (j > 0) and (j < ((N div Coef) - 2)) then
begin
mi := (ValueArray[(j + 1) * Coef + k] - ValueArray[(j - 1) * Coef + k])
/ 2;
mj := (ValueArray[(j + 2) * Coef + k] - ValueArray[j * Coef + k]) / 2;
end;
for i := j * Coef to (j + 1) * Coef do
begin
v1 := ((j + 1) * Coef + k) * Dsc - (i + k) * Dsc;
v2 := (i + k) * Dsc - (j * Coef + k) * Dsc;
resv[k][i + k] := (Sqr(v1) * (2 * v2 + h) * ValueArray[j * Coef + k] +
Sqr(v2) * (2 * v1 + h) * ValueArray[(j + 1) * Coef + k] +
(Sqr(v1) * v2 * mi + Sqr(v2) * (-v1) * mj) / 2) / h / h / h;
end;
end;
for j := Coef to N - 1 - Coef do
begin
av := 0;
for k := 0 to Coef - 1 do
av := av + resv[k][j];
av := av / Coef;
ValueArray[j] := av;
end;
end;
//Гармонический синтез Фурье
procedure FourierAnalysis(var ValueArray: TDoubleArray; NumGarmonics: integer);
var
i, j, N: integer;
yn, ap, bp: double;
AFCoef, BFCoef: TDoubleArray;
begin
N := Length(ValueArray);
SetLength(AFCoef, NumGarmonics);
SetLength(BFCoef, NumGarmonics);
AFCoef[0] := Sum(ValueArray) / N;
BFCoef[0] := 0;
for i := 1 to NumGarmonics - 1 do
begin
AFCoef[i] := 0;
BFCoef[i] := 0;
for j := 0 to N - 1 do
begin
AFCoef[i] := AFCoef[i] + ValueArray[j] * cos(Pi * i * j * 2 / N);
BFCoef[i] := BFCoef[i] + ValueArray[j] * sin(Pi * i * j * 2 / N);
end;
AFCoef[i] := AFCoef[i] * 2 / N;
BFCoef[i] := BFCoef[i] * 2 / N;
end;
for j := 0 to N - 1 do
begin
yn := 0;
ap := 0;
bp := 0;
for i := 1 to NumGarmonics - 1 do
begin
ap := ap + AFCoef[i] * cos(2 * Pi * i * (j / N));
bp := bp + BFCoef[i] * sin(2 * Pi * i * (j / N));
end;
yn := AFCoef[0] + ap + bp;
ValueArray[j] := yn;
end;
end;
//Общая процедура вызова нужного фильтра
procedure DoArraySmoothing(var ValueArray: TDoubleArray; FilterType: integer;
Dsc: double; SplitCoef, ExpandCoef: integer; CycledFilter: boolean);
var
j: integer;
begin
smoothA := nil;
rsmooth := ValueArray;
ArrayExpanding(rsmooth, ExpandCoef);
ArrayLengthening(smoothA, SplitCoef);
if FilterType = 1 then
if CycledFilter then
for j := 2 to SplitCoef do
SevenPointNonLinearSmoothing(smoothA, Dsc, j)
else
SevenPointNonLinearSmoothing(smoothA, Dsc, SplitCoef);
if FilterType = 2 then
CubicSplineSmoothing(smoothA, Dsc, SplitCoef);
ArrayShortening(smoothA, SplitCoef);
ValueArray := smoothA;
end;
//Расширение массива заданным числом точек справа и слева
procedure ArrayLengthening(var ValueArray: TDoubleArray; SplitValue: integer);
var
sv, N, i: integer;
bv, ev: double;
begin
N := Length(ValueArray);
sv := 10 * SplitValue;
bv := 0;
ev := 0;
for i := 0 to 9 do
bv := bv + ValueArray[i];
bv := bv / 10;
for i := N - 1 downto N - 10 do
ev := ev + ValueArray[i];
ev := ev / 10;
SetLength(ValueArray, N + sv);
for i := N - 1 downto 0 do
ValueArray[i + trunc(sv / 2)] := ValueArray[i];
for i := trunc(sv / 2) - 1 downto 0 do
ValueArray[i] := bv;
for i := N + trunc(sv / 2) to N + sv - 1 do
ValueArray[i] := ev;
end;
//Сокращение массива заданным числом точек справа и слева
procedure ArrayShortening(var ValueArray: TDoubleArray; SplitValue: integer);
var
sv, N, i: integer;
begin
N := Length(ValueArray);
sv := 10 * SplitValue;
for i := 0 to N - sv - 1 do
ValueArray[i] := ValueArray[i + trunc(sv / 2)];
SetLength(ValueArray, N - sv);
end;
//Расширение массива заданным числом точек между 2-мя соседними
procedure ArrayExpanding(var ValueArray: TDoubleArray; ExpandCoef: integer);
var
i, k, N, sub: integer;
diap: double;
begin
N := Length(ValueArray);
sub := ExpandCoef - 1;
SetLength(smoothA, N * ExpandCoef - sub);
for i := 0 to N - 1 do
begin
smoothA[i * ExpandCoef] := ValueArray[i];
if i <> 0 then
begin
diap := (smoothA[i * ExpandCoef] - smoothA[(i - 1) * ExpandCoef]);
for k := 0 to ExpandCoef - 1 do
smoothA[(i - 1) * ExpandCoef + k] :=
smoothA[(i - 1) * ExpandCoef] + diap * (k / ExpandCoef);
end;
end;
end;
//Линейная регрессия
procedure LinearRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries,
DestSeries: TChartSeries; var MainCoef, FreeCoef: double;
SeriesColor: TColor; var Hint: string);
var
b0, b1, xsum, ysum, pxy, xsqua: double;
y, x: array of double;
i, N: integer;
s: string;
begin
if ValueArray <> nil then
N := Length(ValueArray)
else
N := SourceSeries.XValues.Count;
pxy := 0;
xsqua := 0;
SetLength(x, N);
SetLength(y, N);
for i := 0 to N - 1 do
begin
if ValueArray <> nil then
begin
y[i] := ValueArray[i];
x[i] := ArgumentArray[i];
end
else
begin
y[i] := SourceSeries.YValues.Value[i];
x[i] := SourceSeries.XValues.Value[i];
end;
pxy := pxy + x[i] * y[i];
xsqua := xsqua + x[i] * x[i];
end;
xsum := Sum(x);
ysum := Sum(y);
b1 := (xsum * ysum - N * pxy) / (xsum * xsum - N * xsqua);
b0 := (ysum - b1 * xsum) / N;
MainCoef := b1;
FreeCoef := b0;
if DestSeries <> nil then
for i := 0 to N - 1 do
if ValueArray <> nil then
DestSeries.AddXY(ArgumentArray[i],
b1 * ArgumentArray[i] + b0, '', SeriesColor)
else
DestSeries.AddXY(SourceSeries.XValues.Value[i],
b1 * SourceSeries.XValues.Value[i] + b0, '', SeriesColor);
if b0 < 0 then
s := ''
else
s := '+ ';
Hint := Format('%0.3f', [b1]) + '*X ' + s + Format('%0.3f', [b0]);
x := nil;
y := nil;
end;
//Гиперболическая регрессия
procedure HyperbolicRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double;
SeriesColor: TColor; var Hint: string);
var
b0, b1, ax, ysum, axsqua, dxy: double;
y, x: array of double;
i, N: integer;
s: string;
begin
if ValueArray <> nil then
N := Length(ValueArray)
else
N := SourceSeries.XValues.Count;
axsqua := 0;
ax := 0;
dxy := 0;
SetLength(x, N);
SetLength(y, N);
for i := 0 to N - 1 do
begin
if ValueArray <> nil then
begin
y[i] := ValueArray[i];
x[i] := ArgumentArray[i];
end
else
begin
y[i] := SourceSeries.YValues.Value[i];
x[i] := SourceSeries.XValues.Value[i];
end;
if x[i] = 0 then
begin
MessageDlg('Hyperbolic regression inapplicable...',
mtWarning, [mbOk], 0);
Hint := 'No equation';
MainCoef := 0;
FreeCoef := 0;
Exit;
end;
dxy := dxy + y[i] / x[i];
ax := ax + 1 / x[i];
axsqua := axsqua + 1 / (x[i] * x[i]);
end;
ysum := Sum(y);
b1 := (dxy - (ysum * ax) / N) / (axsqua - (ax * ax) / N);
b0 := (ysum - b1 * ax) / N;
MainCoef := b1;
FreeCoef := b0;
if DestSeries <> nil then
for i := 0 to N - 1 do
if ValueArray <> nil then
DestSeries.AddXY(ArgumentArray[i],
b1 / ArgumentArray[i] + b0, '', SeriesColor)
else
DestSeries.AddXY(SourceSeries.XValues.Value[i],
b1 / SourceSeries.XValues.Value[i] + b0, '', SeriesColor);
if b0 < 0 then
s := ''
else
s := '+ ';
Hint := Format('%0.3f', [b1]) + '/X ' + s + Format('%0.3f', [b0]);
x := nil;
y := nil;
end;
//Степенная регрессия
procedure PowerRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double;
SeriesColor: TColor; var Hint: string);
var
b0, b1, lnx, lny, xlnsqua, plnxy: double;
y, x: array of double;
i, N: integer;
begin
if ValueArray <> nil then
N := Length(ValueArray)
else
N := SourceSeries.XValues.Count;
lnx := 0;
lny := 0;
xlnsqua := 0;
plnxy := 0;
SetLength(x, N);
SetLength(y, N);
for i := 0 to N - 1 do
begin
if ValueArray <> nil then
begin
y[i] := ValueArray[i];
x[i] := ArgumentArray[i];
end
else
begin
y[i] := SourceSeries.YValues.Value[i];
x[i] := SourceSeries.XValues.Value[i];
end;
if (x[i] <= 0) or (y[i] <= 0) then
begin
MessageDlg('Power regression inapplicable...', mtWarning, [mbOk], 0);
Hint := 'No equation';
MainCoef := 0;
FreeCoef := 0;
Exit;
end;
lnx := lnx + ln(x[i]);
lny := lny + ln(y[i]);
plnxy := plnxy + ln(x[i]) * ln(y[i]);
xlnsqua := xlnsqua + ln(x[i]) * ln(x[i]);
end;
b1 := (lnx * lny - N * plnxy) / (lnx * lnx - N * xlnsqua);
b0 := exp((lny - b1 * lnx) / N);
MainCoef := b1;
FreeCoef := b0;
if DestSeries <> nil then
for i := 0 to N - 1 do
if ValueArray <> nil then
DestSeries.AddXY(ArgumentArray[i],
Power(ArgumentArray[i], b1) * b0, '', SeriesColor)
else
DestSeries.AddXY(SourceSeries.XValues.Value[i],
Power(SourceSeries.XValues.Value[i], b1) * b0, '', SeriesColor);
Hint := Format('%0.3f', [b0]) + '*X^' + Format('%0.3f', [b1]);
x := nil;
y := nil;
end;
//Полиномиальная регрессия
procedure PolynomialRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries; PolyDegree: integer;
var ArrayCoefs: TDoubleArray; SeriesColor: TColor; var Hint: string);
var
bcoef, dcoef: TDoubleArray;
ccoef: array of TDoubleArray;
i, j, k, N: integer;
polynom: double;
begin
if ValueArray <> nil then
N := Length(ValueArray)
else
N := SourceSeries.XValues.Count;
Hint := '';
ArrayCoefs := nil;
SetLength(ccoef, PolyDegree + 1);
for i := 0 to Length(ccoef) - 1 do
SetLength(ccoef[i], PolyDegree + 1);
SetLength(dcoef, PolyDegree + 1);
SetLength(bcoef, PolyDegree + 1);
for i := 0 to Length(dcoef) - 1 do
begin
dcoef[i] := 0;
for j := 0 to N - 1 do
begin
if ValueArray <> nil then
dcoef[i] := dcoef[i] +
Power(ArgumentArray[j], i) * ValueArray[j]
else
dcoef[i] := dcoef[i] + Power(SourceSeries.XValues.Value[j], i) *
SourceSeries.YValues.Value[j];
end;
for j := 0 to Length(ccoef) - 1 do
begin
ccoef[i][j] := 0;
for k := 0 to N - 1 do
begin
if ValueArray <> nil then
ccoef[i][j] :=
ccoef[i][j] + Power(ArgumentArray[k], i + j)
else
ccoef[i][j] := ccoef[i][j] + Power(SourceSeries.XValues.Value[k], i +
j);
end;
end;
end;
for i := 0 to Length(ccoef) - 2 do
for j := i + 1 to Length(ccoef) - 1 do
begin
ccoef[j][i] := -ccoef[j][i] / ccoef[i][i];
dcoef[j] := dcoef[j] + ccoef[j][i] * dcoef[i];
for k := i + 1 to Length(ccoef) - 1 do
ccoef[j][k] := ccoef[j][k] + ccoef[j][i] * ccoef[i][k];
end;
bcoef[Length(bcoef) - 1] := dcoef[Length(dcoef) - 1] /
ccoef[Length(bcoef) - 1][Length(bcoef) - 1];
for i := Length(ccoef) - 2 downto 0 do
begin
for j := i + 1 to Length(ccoef) - 1 do
bcoef[i] := bcoef[i] + bcoef[j] * ccoef[i][j];
bcoef[i] := (dcoef[i] - bcoef[i]) / ccoef[i][i];
end;
SetLength(ArrayCoefs, Length(bcoef));
for i := 0 to Length(bcoef) - 1 do
ArrayCoefs[i] := bcoef[i];
if DestSeries <> nil then
for i := 0 to N - 1 do
begin
polynom := 0;
if ValueArray <> nil then
begin
for j := 0 to PolyDegree do
polynom := polynom + bcoef[j] * Power(ArgumentArray[i], j);
DestSeries.AddXY(ArgumentArray[i], polynom, '', SeriesColor);
end
else
begin
for j := 0 to PolyDegree do
polynom := polynom +
bcoef[j] * Power(SourceSeries.XValues.Value[i], j);
DestSeries.AddXY(SourceSeries.XValues.Value[i],
polynom, '', SeriesColor);
end;
end;
for j := PolyDegree downto 0 do
Hint := Hint + Format('%0.3f', [bcoef[j]]) + '*X^' + IntToStr(j);
dcoef := nil;
bcoef := nil;
ccoef := nil;
end;
//Показательная регрессия
procedure ExponentRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double;
SeriesColor: TColor; var Hint: string; Warning: boolean);
var
i, N: integer;
x, y: array of double;
lgy, xsum, xsqua, a, b, lga, xlgy, lgb: double;
begin
if ValueArray <> nil then
N := Length(ValueArray)
else
N := SourceSeries.XValues.Count;
lgy := 0;
xsqua := 0;
xlgy := 0;
SetLength(x, N);
SetLength(y, N);
for i := 0 to N - 1 do
begin
if ValueArray <> nil then
begin
y[i] := ValueArray[i];
x[i] := ArgumentArray[i];
end
else
begin
y[i] := SourceSeries.YValues.Value[i];
x[i] := SourceSeries.XValues.Value[i];
end;
if y[i] <= 0 then
begin
if Warning then
MessageDlg('Exponent regression inapplicable',
mtWarning, [mbOk], 0);
Hint := 'No equation';
MainCoef := 0;
FreeCoef := 0;
Exit;
end;
lgy := lgy + Log10(y[i]);
xsqua := xsqua + x[i] * x[i];
xlgy := xlgy + x[i] * Log10(y[i]);
end;
xsum := Sum(x);
lgb := (xlgy - (lgy * xsum) / N) / (xsqua - (xsum * xsum) / N);
lga := (lgy - lgb * xsum) / N;
b := Power(10, lgb);
a := Power(10, lga);
MainCoef := b;
FreeCoef := a;
if DestSeries <> nil then
for i := 0 to N - 1 do
if ValueArray <> nil then
DestSeries.AddXY(ArgumentArray[i],
a * Power(b, ArgumentArray[i]), '', SeriesColor)
else
DestSeries.AddXY(SourceSeries.XValues.Value[i],
a * Power(b, SourceSeries.XValues.Value[i]), '', SeriesColor);
Hint := 'Exponent regression equation: Y = ' +
Format('%0.5f', [a]) + ' * (' + Format('%0.5f', [b]) + ' ^ X)';
x := nil;
y := nil;
end;
//Экспоненциальная регрессия
procedure ExponentialRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double;
SeriesColor: TColor; var Hint: string; Warning: boolean);
var
i, N: integer;
x, y: array of double;
lny, xsum, xsqua, xlny, b0, b1: double;
begin
MainCoef := 0;
FreeCoef := 0;
if ValueArray <> nil then
N := Length(ValueArray)
else
N := SourceSeries.XValues.Count;
lny := 0;
xsqua := 0;
xlny := 0;
SetLength(x, N);
SetLength(y, N);
for i := 0 to N - 1 do
begin
if ValueArray <> nil then
begin
y[i] := ValueArray[i];
x[i] := ArgumentArray[i];
end
else
begin
y[i] := SourceSeries.YValues.Value[i];
x[i] := SourceSeries.XValues.Value[i];
end;
if y[i] <= 0 then
begin
if Warning then
MessageDlg('Exponential regression inapplicable',
mtWarning, [mbOk], 0);
Hint := 'No equation';
MainCoef := 0;
FreeCoef := 0;
Exit;
end;
lny := lny + Ln(y[i]);
xsqua := xsqua + x[i] * x[i];
xlny := xlny + x[i] * Ln(y[i]);
end;
xsum := Sum(x);
b1 := (xsum * lny - N * xlny) / (xsum * xsum - N * xsqua);
b0 := exp((lny - b1 * xsum) / N);
MainCoef := b1;
FreeCoef := b0;
if DestSeries <> nil then
for i := 0 to N - 1 do
if ValueArray <> nil then
DestSeries.AddXY(ArgumentArray[i],
b0 * Exp(b1 * ArgumentArray[i]), '', SeriesColor)
else
DestSeries.AddXY(SourceSeries.XValues.Value[i],
b0 * Exp(b1 * SourceSeries.XValues.Value[i]), '', SeriesColor);
Hint := 'Exponential regression equation: Y = ' +
Format('%0.5f', [b0]) + ' * exp(' + Format('%0.5f', [b1]) + ' * X)';
x := nil;
y := nil;
end;
//Степенно-экспоненциальная регрессия
procedure ExpPowerRegression(ValueArray, ArgumentArray: TDoubleArray;
SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double;
SeriesColor: TColor; var Hint: string; Warning: boolean);
var
i, N: integer;
x, y: array of double;
matr: array[0..3] of double;
lny, xsum, xsqua, xlny, b0, b1: double;
begin
MainCoef := 0;
FreeCoef := 0;
if ValueArray <> nil then
N := Length(ValueArray)
else
N := SourceSeries.XValues.Count;
lny := 0;
xsqua := 0;
xlny := 0;
SetLength(x, N);
SetLength(y, N);
for i := 0 to N - 1 do
begin
if ValueArray <> nil then
begin
y[i] := ValueArray[i];
x[i] := ArgumentArray[i];
end
else
begin
y[i] := SourceSeries.YValues.Value[i];
x[i] := SourceSeries.XValues.Value[i];
end;
if y[i] <= 0 then
begin
if Warning then
MessageDlg('Exponent-Power regression inapplicable',
mtWarning, [mbOk], 0);
Hint := 'No equation';
MainCoef := 0;
FreeCoef := 0;
Exit;
end;
lny := lny + Ln(y[i]);
xsqua := xsqua + x[i] * x[i];
xlny := xlny + x[i] * Ln(y[i]);
end;
xsum := Sum(x);
b1 := (xsum * lny - N * xlny) / (xsum * xsum - N * xsqua);
b0 := exp((lny - b1 * xsum) / N);
MainCoef := b1;
FreeCoef := b0;
if DestSeries <> nil then
for i := 0 to N - 1 do
if ValueArray <> nil then
DestSeries.AddXY(ArgumentArray[i],
b0 * Exp(b1 * ArgumentArray[i]), '', SeriesColor)
else
DestSeries.AddXY(SourceSeries.XValues.Value[i],
b0 * Exp(b1 * SourceSeries.XValues.Value[i]), '', SeriesColor);
Hint := 'Exponent-Power regression equation: Y = ' +
Format('%0.5f', [b0]) + ' * exp(' + Format('%0.5f', [b1]) + ' * X)';
x := nil;
y := nil;
end;
//Общая процедура проверки массива
procedure CheckArrayBounds(var CArray: TDoubleArray; var FromPoint, ToPoint:
integer);
begin
if FromPoint < 0 then
FromPoint := 0;
if (ToPoint <= 0) or (ToPoint > Length(CArray) - 1) then
ToPoint := Length(CArray) - 1;
if FromPoint > ToPoint then
ToPoint := FromPoint;
end;
//Общая процедура проверки серии
procedure CheckSeriesBounds(CSeries: TChartSeries; var FromPoint, ToPoint:
integer);
begin
if FromPoint < 0 then
FromPoint := 0;
if (ToPoint <= 0) or (ToPoint > CSeries.XValues.Count - 1) then
ToPoint := CSeries.XValues.Count - 1;
if FromPoint > ToPoint then
ToPoint := FromPoint;
end;
//Извлечение массива из массива
procedure ArrayFromArray(var SourceArray, DestArray: TDoubleArray;
FromPoint, ToPoint, Discrete: integer; Derivative: boolean);
var
i: integer;
begin
DestArray := nil;
if SourceArray = nil then
DestArray := nil
else
begin
CheckArrayBounds(SourceArray, FromPoint, ToPoint);
if Discrete = 0 then
Discrete := 1;
if Derivative = false then
begin
SetLength(DestArray, ((ToPoint - FromPoint) div Discrete) + 1);
for i := 0 to Length(DestArray) - 1 do
DestArray[i] :=
SourceArray[i * Discrete + FromPoint];
end
else
begin
SetLength(DestArray, ((ToPoint - FromPoint) div Discrete));
for i := 1 to Length(DestArray) do
DestArray[i - 1] :=
(SourceArray[i * Discrete + FromPoint] -
SourceArray[i * Discrete + FromPoint - 1]) / Discrete;
end;
end;
end;
//Извлечение массива из серии
procedure ArrayFromSeries(var ValueArray: TDoubleArray; DataSeries:
TChartSeries;
FromPoint, ToPoint, Discrete: integer; Derivative: boolean);
var
i: integer;
begin
if DataSeries = nil then
ValueArray := nil
else
with DataSeries do
begin
CheckSeriesBounds(DataSeries, FromPoint, ToPoint);
if Discrete = 0 then
Discrete := 1;
if Derivative = false then
begin
SetLength(ValueArray, ((ToPoint - FromPoint) div Discrete) + 1);
for i := 0 to Length(ValueArray) - 1 do
ValueArray[i] :=
YValues.Value[i * Discrete + FromPoint];
end
else
begin
SetLength(ValueArray, ((ToPoint - FromPoint) div Discrete));
for i := 1 to Length(ValueArray) do
ValueArray[i - 1] :=
(YValues.Value[i * Discrete + FromPoint] - YValues.Value[i * Discrete
+ FromPoint - 1]) /
(XValues.Value[i * Discrete + FromPoint] -
XValues.Value[i * Discrete + FromPoint - 1]);
end;
end;
end;
//Извлечение серии из массива
procedure SeriesFromArray(var ValueArray: TDoubleArray; DataSeries:
TChartSeries;
FromPoint, ToPoint, Discrete: integer; Derivative: boolean);
var
i, n: integer;
begin
if DataSeries = nil then
Exit
else
with DataSeries do
begin
Clear;
CheckArrayBounds(ValueArray, FromPoint, ToPoint);
if Discrete = 0 then
Discrete := 1;
if Derivative = false then
begin
n := ((ToPoint - FromPoint) div Discrete) + 1;
for i := 0 to n - 1 do
DataSeries.AddXY(i, ValueArray[i * Discrete + FromPoint],
'', DataSeries.SeriesColor);
end
else
begin
n := (ToPoint - FromPoint) div Discrete;
for i := 1 to n do
DataSeries.AddXY(i - 1, (ValueArray[i * Discrete + FromPoint] -
ValueArray[i * Discrete + FromPoint - 1]) / Discrete,
'', DataSeries.SeriesColor);
end;
end;
end;
//Извлечение производной из массива
function DerivFromArray(var SourceArray: TDoubleArray; FromPoint, ToPoint,
Discrete: integer; Extremum: string; var Position: integer): double;
var
i: integer;
d: double;
begin
DerivFromArray := 0;
if SourceArray = nil then
DerivFromArray := 0
else
begin
CheckArrayBounds(SourceArray, FromPoint, ToPoint);
if Discrete = 0 then
Discrete := 1;
SetLength(rv, (ToPoint - FromPoint) div Discrete);
for i := 1 to Length(rv) do
rv[i - 1] := (SourceArray[i * Discrete + FromPoint] -
SourceArray[i * Discrete + FromPoint - 1]) / Discrete;
if Extremum = 'max' then
d := MaxValue(rv);
if Extremum = 'min' then
d := MinValue(rv);
if Extremum = 'mean' then
d := Mean(rv);
for i := 0 to Length(rv) - 1 do
if rv[i] = d then
begin
Position := i;
break;
end;
DerivFromArray := d;
end;
end;
//Извлечение производной из серии
function DerivFromSeries(DataSeries: TChartSeries; FromPoint, ToPoint,
Discrete: integer; Extremum: string; var Position: integer): double;
var
i: integer;
d: double;
begin
DerivFromSeries := 0;
if DataSeries = nil then
DerivFromSeries := 0
else
with DataSeries do
begin
CheckSeriesBounds(DataSeries, FromPoint, ToPoint);
if Discrete = 0 then
Discrete := 1;
SetLength(rv, (ToPoint - FromPoint) div Discrete);
for i := 1 to Length(rv) do
rv[i - 1] := (YValues.Value[i * Discrete + FromPoint] -
YValues.Value[i * Discrete + FromPoint - 1]) / (XValues.Value[i *
Discrete + FromPoint] -
XValues.Value[i * Discrete + FromPoint - 1]);
if Extremum = 'max' then
d := MaxValue(rv);
if Extremum = 'min' then
d := MinValue(rv);
if Extremum = 'mean' then
d := Mean(rv);
for i := 0 to Length(rv) - 1 do
if rv[i] = d then
begin
Position := i;
break;
end;
DerivFromSeries := d;
end;
end;
//Извлечение величины из серии
function ValueFromSeries(DataSeries: TChartSeries; FromPoint, ToPoint: integer;
Extremum: string; var Position: integer): double;
var
i: integer;
d: double;
begin
if DataSeries = nil then
ValueFromSeries := 0
else
with DataSeries do
begin
CheckSeriesBounds(DataSeries, FromPoint, ToPoint);
SetLength(rv, ToPoint - FromPoint);
for i := 0 to Length(rv) - 1 do
rv[i] := YValues.Value[FromPoint + i];
if Extremum = 'max' then
d := MaxValue(rv);
if Extremum = 'min' then
d := MinValue(rv);
if Extremum = 'mean' then
d := Mean(rv);
for i := 0 to Length(rv) - 1 do
if rv[i] = d then
begin
Position := i;
break;
end;
ValueFromSeries := d;
end;
end;
//Извлечение величины из массива
function ValueFromArray(var SourceArray: TDoubleArray; FromPoint,
ToPoint: integer; Extremum: string; var Position: integer): double;
var
i: integer;
d: double;
begin
if SourceArray = nil then
ValueFromArray := 0
else
begin
CheckArrayBounds(SourceArray, FromPoint, ToPoint);
SetLength(rv, ToPoint - FromPoint);
for i := 0 to Length(rv) - 1 do
rv[i] := SourceArray[FromPoint + i];
if Extremum = 'max' then
d := MaxValue(rv);
if Extremum = 'min' then
d := MinValue(rv);
if Extremum = 'mean' then
d := Mean(rv);
for i := 0 to Length(rv) - 1 do
if rv[i] = d then
begin
Position := i;
break;
end;
ValueFromArray := d;
end;
end;
//Вычисление площади под кривой, получаемой данными из массива
function CalculateAreaOfArray(var SourceArray: TDoubleArray;
FromPoint, ToPoint, Method: integer; BindToZero: boolean): double;
var
i: integer;
sq, subv: double;
begin
if SourceArray = nil then
CalculateAreaOfArray := 0
else
begin
CheckArrayBounds(SourceArray, FromPoint, ToPoint);
sq := 0;
if BindToZero then
subv :=
(SourceArray[ToPoint] + SourceArray[FromPoint]) / 2
else
subv := 0;
for i := FromPoint to ToPoint - 1 do
begin
if Method = 1 then
sq := sq + Abs(SourceArray[i] - subv) +
(Abs(SourceArray[i + 1] - subv) - Abs(SourceArray[i] - subv)) / 2;
if Method = 2 then
sq := sq + Abs(SourceArray[i] - subv) +
(Abs(SourceArray[i + 1] - subv) - Abs(SourceArray[i] - subv)) / 2 - 1
/ (48 * Power(0.5, 1.5));
if Method = 3 then
if (i mod 2) = 1 then
sq := sq + 2 * Abs(SourceArray[i] - subv);
if Method = 4 then
if (i mod 2) = 1 then
sq := sq + 2 * Abs(SourceArray[i] - subv) - 1 / (96 * Power(0.5,
1.5));
end;
CalculateAreaOfArray := sq;
end;
end;
//Вычисление площади под кривой, получаемой данными из серии
function CalculateAreaOfSeries(DataSeries: TChartSeries; FromPoint, ToPoint,
Method: integer; BindToZero: boolean): double;
var
i: integer;
sq, subv: double;
begin
if DataSeries = nil then
CalculateAreaOfSeries := 0
else
with DataSeries do
begin
CheckSeriesBounds(DataSeries, FromPoint, ToPoint);
sq := 0;
if BindToZero then
subv := (YValues.Value[ToPoint] +
YValues.Value[FromPoint]) / 2
else
subv := 0;
for i := FromPoint to ToPoint - 1 do
begin
if Method = 1 then
sq := sq + Abs(YValues.Value[i] - subv) +
(Abs(YValues.Value[i + 1] - subv) - Abs(YValues.Value[i] - subv)) /
2;
if Method = 2 then
sq := sq + Abs(YValues.Value[i] - subv) +
(Abs(YValues.Value[i + 1] - subv) -
Abs(YValues.Value[i] - subv)) / 2 - 1 / (48 * Power(0.5, 1.5));
if Method = 3 then
if (i mod 2) = 1 then
sq := sq + 2 * Abs(YValues.Value[i] - subv);
if Method = 4 then
if (i mod 2) = 1 then
sq := sq + 2 * Abs(YValues.Value[i] - subv) - 1 / (96 * Power(0.5,
1.5));
end;
CalculateAreaOfSeries := sq;
end;
end;
//Исключение линейной составляющей
procedure LinearTrendExclusion(var ValueArray: TDoubleArray);
var
i, N: integer;
b0, b1, nx: double;
begin
N := Length(ValueArray);
nx := 0;
for i := 0 to N - 1 do
nx := nx + (i + 1) * ValueArray[i];
b0 := (2 * (2 * N + 1) * Sum(ValueArray) - 6 * nx) / (N * (N - 1));
b1 := (12 * nx - 6 * (N + 1) * Sum(ValueArray)) / (N * (N - 1) * (N + 1));
for i := 0 to N - 1 do
begin
ValueArray[i] := ValueArray[i] - (i * b1);
end;
end;
//Расцветка серии
procedure ColorizeSeries(DataSeries: TChartSeries; NewColor: TColor);
var
i: integer;
begin
for i := 0 to DataSeries.XValues.Count - 1 do
DataSeries.ValueColor[i] := NewColor;
end;
//Задание нового приращения по оси X
procedure SetXInterval(DataSeries: TChartSeries; XInterval: double);
var
i: integer;
begin
for i := 0 to DataSeries.XValues.Count - 1 do
DataSeries.XValues.Value[i] := DataSeries.XValues.Value[i] * XInterval;
end;
//Привязка серии к новой оси
procedure SetSeriesAxis(DataSeries: TChartSeries; NewAxis: TVertAxis);
begin
DataSeries.VertAxis := NewAxis;
end;
end.
|
Автор проекта: ___Nikolay