Фильтрация, регрессия, работа с массивом и серией
Материал из DRKB
{ **** UBPFD *********** by kladovka.net.ru ****
>> Фильтрация, регрессия, работа с массивом и серией
Модуль предназначен для выполнения процедур:
- фильтрации
- регрессии
- операций с массивами
- операций с сериями
Зависимости: 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;
// Расширение массива заданным числом точек между 2-мя соседними
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);
// Нелинейный фильтр по 7 точкам
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);
// Задание нового приращения по оси X
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
Result := 0;
if SourceArray = nil then
Result := 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;
Result := d;
end;
end;
// Извлечение производной из серии
function DerivFromSeries(DataSeries: TChartSeries;
FromPoint, ToPoint, Discrete: Integer; Extremum: string;
var Position: Integer): Double;
var
i: Integer;
d: Double;
begin
Result := 0;
if DataSeries = nil then
Result := 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;
Result := 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
Result := 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;
Result := 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
Result := 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;
Result := 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
Result := 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;
Result := 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
Result := 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;
Result := 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.
Author: lookin
ID: 03964
ID: 04225