unit CoFitter;
{$WARN SYMBOL_PLATFORM OFF}
{$B-}
interface
uses
ComObj, ActiveX, Events, Classes, Fitter_TLB, StdVcl;
type
TDMFitter = class(TAutoObject, IConnectionPointContainer, IDMFitter)
private
FConnectionPoints: TConnectionPoints;
FConnectionPoint: TConnectionPoint;
FX,
FY,
FWeight,
FExpression,
FParameters,
FSigmas,
FOptions: OleVariant;
FXDimension,
FWeightType,
FParamCount,
FIterations,
FResultCode: integer;
FDeviation: double;
FStrExpr: array[0..4096] of char; public
procedure Initialize; override;
protected
property ConnectionPoints: TConnectionPoints read FConnectionPoints
implements IConnectionPointContainer;
function Get_Expression: OleVariant; safecall;
function LinearFit: WordBool; safecall;
function LMFit: WordBool; safecall;
procedure Set_Expression(Value: OleVariant); safecall;
function Get_Deviation: Double; safecall;
function Get_Iterations: Integer; safecall;
function Get_Options: OleVariant; safecall;
function Get_ParamCount: Integer; safecall;
function Get_Parameters: OleVariant; safecall;
function Get_ResultCode: Integer; safecall;
function Get_Sigmas: OleVariant; safecall;
function Get_Weight: OleVariant; safecall;
function Get_WeightType: Integer; safecall;
function Get_X: OleVariant; safecall;
function Get_Y: OleVariant; safecall;
procedure Set_Iterations(Value: Integer); safecall;
procedure Set_Options(Value: OleVariant); safecall;
procedure Set_ParamCount(Value: Integer); safecall;
procedure Set_Parameters(Value: OleVariant); safecall;
procedure Set_Sigmas(Value: OleVariant); safecall;
procedure Set_Weight(Value: OleVariant); safecall;
procedure Set_WeightType(Value: Integer); safecall;
procedure Set_X(Value: OleVariant); safecall;
procedure Set_Y(Value: OleVariant); safecall;
end;
function SetVariantArray(const Value: variant): variant;
procedure SetXVector(const DA: array of double); implementation
uses ComServ, Windows, Variants, SysUtils
{$ifndef dmmath}, Parser, LMFit, Wrapper{$endif};
{$ifdef dmmath}
{$I DMData.inc}
FitArray=TRealArray;
{$I DMMath.inc}
{$endif}
// need following function to avoid confusion with TDMFitter member
// in the pre-build300 versions we have to use Wrapper.LinearFit qualifier
function LinFit(NumPoints, NumTerms, FitType: integer; X, Y, Solution: pointer;
var StandardDeviation, Variance: double): integer;
begin
LinFit:=LinearFit(NumPoints, NumTerms, FitType, X, Y, Solution,
StandardDeviation, Variance);
end;
threadvar Fitter: variant; DMFitter: TDMFitter; Pars, Sig, XVector: TRealArray;
UseXVector: boolean; procedure SetXVector(const DA: array of double);
var
I: integer;
begin
Assert(Length(DA)=MaxCols); for I:=1 to MaxCols do
XVector[I]:=DA[I-1];
end;
function GetX(X: TReal): variant; var I: integer;
begin
if DMFitter.FXDimension>0 then begin
Result:=VarArrayCreate([0, DMFitter.FXDimension], varVariant);
Assert((Round(X)>=0) and (Round(X)<=(VarArrayHighBound(DMFitter.FX, 1))));
for I:=0 to DMFitter.FXDimension do
Result[I]:=DMFitter.FX[Round(X), I];
end else
Result:=X; end;
function LMFitFunc(X: TReal; A: FitArray; NParam: Integer): TReal; stdcall;
var
vP: variant;
I: integer;
begin
vP:=VarArrayCreate([0, NParam-1], varVariant);
for I:=0 to NParam-1 do
vP[I]:=A[I+1];
Result:=Fitter.CalculateFunction(GetX(X), vP);
end;
procedure LMFitDeriv(X: TReal; A, SigA: FitArray; NParam: Integer;
var Deriv: FitArray); stdcall;
var
vPar, vSig, vRes: variant;
I: integer;
begin
vPar:=VarArrayCreate([0, NParam-1], varVariant);
vSig:=VarArrayCreate([0, NParam-1], varVariant);
for I:=0 to NParam-1 do
begin
vPar[I]:=A[I+1];
vSig[I]:=SigA[I+1];
end;
vRes:=Fitter.CalculateDerivative(GetX(X), vPar, vSig);
for I:=0 to NParam-1 do
Deriv[I+1]:=vRes[I]; end;
procedure LMFitProgress; stdcall;
var
I: integer;
begin
if Assigned(DMFitter) then
begin
for I:=0 to VarArrayHighBound(DMFitter.FParameters,1) do
begin DMFitter.FParameters[I]:=Pars[I+1];
DMFitter.FSigmas[I]:=Sig[I+1];
end;
if Assigned(DMFitter.FConnectionPoint) then
for I:=0 to DMFitter.FConnectionPoint.SinkList.Count-1 do
(IUnknown(DMFitter.FConnectionPoint.SinkList[I]) as
IDMFitterEvents).OnProgress;
end;
end;
function LinearFitBasis(X: double; Term: integer): double; stdcall;
var
I: integer;
R: double;
begin
Result:=0;
if Assigned(DMFitter.FConnectionPoint) then
for I:=0 to DMFitter.FConnectionPoint.SinkList.Count-1 do
begin
R:=(IUnknown(DMFitter.FConnectionPoint.SinkList[I]) as
IDMFitterEvents).OnGetLinearBasis(X, Term);
if R<>0 then
Result:=R;
end;
end;
function LMFitFunc3(X: TReal; A: FitArray; NParam: Integer): TReal; stdcall;
var
I: integer;
begin
Assert(UseXVector);
Assert(DMFitter.FXDimension>0);
Assert((Round(X)>=0) and (Round(X)<=(VarArrayHighBound(DMFitter.FX, 1))));
for I:=0 to DMFitter.FXDimension do XVector[I+1]:=DMFitter.FX[Round(X), I]; Result:=NLSFParse(DMFitter.FStrExpr, XVector[1], TRealArray(A));
end;
function LMFitFunc2(X: TReal; A: FitArray; NParam: Integer): TReal; stdcall;
var
VA: variant;
I: integer;
R: double;
begin
VA:=VarArrayCreate([0, NParam-1], varVariant);
for I:=0 to NParam-1 do
VA[I]:=A[I+1];
Result:=0;
if Assigned(DMFitter.FConnectionPoint) then
for I:=0 to DMFitter.FConnectionPoint.SinkList.Count-1 do
begin
R:=(IUnknown(DMFitter.FConnectionPoint.SinkList[I]) as
IDMFitterEvents).OnGetLMFunction(GetX(X), VA);
if R<>0 then Result:=R;
end;
end;
procedure LMFitDeriv2(X: TReal; A, SigA: FitArray; NParam: Integer;
var Deriv: FitArray); stdcall;
var
VA, VSigA, Res, R: variant;
I: integer;
begin
VA:=VarArrayCreate([0, NParam-1], varVariant);
VSigA:=VarArrayCreate([0, NParam-1], varVariant);
for I:=0 to NParam-1 do
begin
VA[I]:=A[I+1];
VSigA[I]:=SigA[I+1];
end;
R:=Unassigned;
Res:=Unassigned;
if Assigned(DMFitter.FConnectionPoint) then
for I:=0 to DMFitter.FConnectionPoint.SinkList.Count-1 do
begin
R:=(IUnknown(DMFitter.FConnectionPoint.SinkList[I]) as
IDMFitterEvents).OnGetLMDerivative(GetX(X), VA, VSigA);
if not VarIsEmpty(R) then Res:=SetVariantArray(R);
end;
Assert(VarIsArray(Res)); Assert(VarArrayHighBound(Res,1)=NParam-1);
for I:=0 to VarArrayHighBound(Res,1) do
Deriv[I+1]:=Res[I];
end;
procedure LMFitDeriv3(X: TReal; A, SigA: FitArray; NParam: Integer;
var Deriv: FitArray); stdcall; var
I: integer;
A1: FitArray;
Y1, Y2, dP, NLSFDelta: TReal;
begin
if VarIsArray(DMFitter.FOptions) and (VarArrayHighBound(DMFitter.FOptions,1)=2)
then NLSFDelta:=DMFitter.FOptions[2]
else NLSFDelta:=1e-10;
if NLSFDelta<=0 then NLSFDelta:=1e-10; for I:=1 to Nparam do
if SigA[I]<0 then Deriv[I]:=0 else
begin
if Abs(A[I])<NLSFDelta
then dP:=NLSFDelta
else dP:=Abs(A[I])*NLSFDelta;
A1:=A;
A1[I]:=A1[I]-dP;
if UseXVector
then Y1:=LMFitFunc3(X, A1, Nparam)
else Y1:=LMFitFunc2(X, A1, Nparam);
A1:=A;
A1[I]:=A1[I]+dP;
if UseXVector
then Y2:=LMFitFunc3(X, A1, Nparam)
else Y2:=LMFitFunc2(X, A1, Nparam);
Deriv[I]:=(Y2-Y1)/2/dP;
end;
end;
procedure TDMFitter.Initialize;
begin
inherited Initialize;
FConnectionPoints := TConnectionPoints.Create(Self);
if AutoFactory.EventTypeInfo <> nil then
FConnectionPoint := FConnectionPoints.CreateConnectionPoint(
AutoFactory.EventIID, ckMulti, EventConnect)
else FConnectionPoint := nil;
end;
function TDMFitter.LinearFit: WordBool;
var
DX, DY, Res: array of double;
Va: double;
I, NumPoints, FitType: integer;
begin
Result:=false; FResultCode:=3;
if not (VarIsArray(FX) and VarIsArray(FY))
then Exit; NumPoints:=VarArrayHighBound(FX, 1)+1;
if (VarArrayHighBound(FY, 1)+1<>NumPoints)
then Exit; if VarIsStr(FExpression) then
begin
StrPLCopy(FStrExpr, FExpression, SizeOf(FStrExpr)-1);
FitType:=-2; end else
if VarIsOrdinal(FExpression) then
begin
FitType:=FExpression;
if not ((FitType in [0..5]) or (FitType=-1)) then Exit; end else Exit; FResultCode:=1;
SetLength(DX, NumPoints);
SetLength(DY, NumPoints); SetLength(Res, 100);
for I:=0 to NumPoints-1 do begin
DX[I]:=FX[I];
DY[I]:=FY[I];
end;
if FitType=-1 then
try
DMFitter:=self; FResultCode:=LinearFitEx(NumPoints,
FParamCount or LinearFitExNumTermsMask, @LinearFitBasis,
@DX[0], @DY[0], @Res[0], FDeviation, Va)
finally
DMFitter:=nil;
end else
if FitType=-2
then FResultCode:=LinearFitEx(NumPoints, FParamCount, @FStrExpr,
@DX[0], @DY[0], @Res[0], FDeviation, Va)
else FResultCode:=LinFit(NumPoints, FParamCount, FitType,
@DX[0], @DY[0], @Res[0], FDeviation, Va);
FParameters:=VarArrayCreate([0, FParamCount-1], varVariant);
for I:=0 to FParamCount-1 do
FParameters[I]:=Res[I];
Result:=FResultCode=0; end;
function TDMFitter.LMFit: WordBool;
var
rX, rY, rW: array of TReal;
Chi, ParDel, ChiDel, Deriv: TReal;
I, NumPoints, EventMode: integer;
WP: pointer;
begin
Result:=false; FResultCode:=3;
Fitter:=Unassigned;
if not (FWeightType in [0..2])
then Exit; if (FIterations<1) or (FIterations>10000)
then Exit;
if (FParamCount<1) or (FParamCount>25)
then Exit;
EventMode:=0; if VarIsStr(FExpression)
then StrPLCopy(FStrExpr, FExpression, SizeOf(FStrExpr)-1)
else if VarIsType(FExpression, varDispatch) then Fitter:=VarAsType(FExpression, varDispatch)
else if VarIsOrdinal(FExpression) then EventMode:=FExpression
else Exit;
if VarIsStr(FExpression) then begin
UseXVector:=Pos('CX2', UpperCase(FStrExpr))>0;
if UseXVector and (FXDimension=0)
then Exit;
end;
if not (VarIsArray(FX) and VarIsArray(FY))
then Exit;
if FWeightType>0 then if not VarIsArray(FWeight)
then Exit;
NumPoints:=VarArrayHighBound(FX,1)+1;
if (VarArrayHighBound(FY,1)+1<>NumPoints) or
((FWeightType>0) and (VarArrayHighBound(FWeight,1)+1<>NumPoints))
then Exit;
if not (VarIsArray(FParameters) and VarIsArray(FSigmas))
then Exit;
if VarArrayHighBound(FParameters,1)<>VarArrayHighBound(FSigmas,1)
then Exit;
if VarArrayHighBound(FParameters,1)<>FParamCount-1
then Exit;
for I:=0 to VarArrayHighBound(FParameters,1) do
begin
Pars[I+1]:=FParameters[I];
Sig[I+1]:=FSigmas[I];
end;
if VarIsArray(FOptions) and (VarArrayHighBound(FOptions,1)=2) then
begin
ParDel:=FOptions[0];
ChiDel:=FOptions[1];
Deriv:=FOptions[2];
end else
begin
ParDel:=0;
ChiDel:=0;
Deriv:=0;
end;
SetLength(rX, NumPoints);
SetLength(rY, NumPoints);
if FWeightType>0 then
begin
SetLength(rW, NumPoints);
WP:=@rW[0];
end else
WP:=nil;
FResultCode:=1;
for I:=0 to NumPoints-1 do
begin
if FXDimension>0
then rX[I]:=I else rX[I]:=FX[I];
rY[I]:=FY[I];
if FWeightType>0
then rW[I]:=FWeight[I];
end;
DMFitter:=self; try
case EventMode of
0: if VarIsEmpty(Fitter) then
if UseXVector
then FResultCode:=LMNLSFEx(NumPoints, FParamCount, FWeightType,
@rX[0], @rY[0], WP, Pars, Sig, FIterations,
LMFitProgress, LMFitFunc3, LMFitDeriv3, Chi, ParDel, ChiDel)
else FResultCode:=LMNLSF(FStrExpr, NumPoints, FWeightType, @rX[0], @rY[0],
WP, Pars, Sig, FIterations, LMFitProgress, Chi, ParDel, ChiDel, Deriv)
else FResultCode:=LMNLSFEx(NumPoints, FParamCount, FWeightType,
@rX[0], @rY[0], WP, Pars, Sig, FIterations,
LMFitProgress, LMFitFunc, LMFitDeriv, Chi, ParDel, ChiDel);
-1: FResultCode:=LMNLSFEx(NumPoints, FParamCount, FWeightType,
@rX[0], @rY[0], WP, Pars, Sig, FIterations,
LMFitProgress, LMFitFunc2, LMFitDeriv2, Chi, ParDel, ChiDel);
-2: FResultCode:=LMNLSFEx(NumPoints, FParamCount, FWeightType,
@rX[0], @rY[0], WP, Pars, Sig, FIterations,
LMFitProgress, LMFitFunc2, LMFitDeriv3, Chi, ParDel, ChiDel);
else
Exit;
end;
finally
DMFitter:=nil;
end;
FDeviation:=Chi;
for I:=0 to VarArrayHighBound(FParameters,1) do
begin
FParameters[I]:=Pars[I+1];
FSigmas[I]:=Sig[I+1];
end;
Fitter:=Unassigned; Result:=not (FResultCode in [1..3]); end;
function TDMFitter.Get_Expression: OleVariant;
begin
Result:=FExpression;
end;
function TDMFitter.Get_Deviation: Double;
begin
Result:=FDeviation;
end;
function TDMFitter.Get_Iterations: Integer;
begin
Result:=FIterations;
end;
function TDMFitter.Get_Options: OleVariant;
begin
Result:=FOptions;
end;
function TDMFitter.Get_ParamCount: Integer;
begin
Result:=FParamCount;
end;
function TDMFitter.Get_Parameters: OleVariant;
begin
Result:=FParameters;
end;
function TDMFitter.Get_ResultCode: Integer;
begin
Result:=FResultCode;
end;
function TDMFitter.Get_Sigmas: OleVariant;
begin
Result:=FSigmas;
end;
function TDMFitter.Get_Weight: OleVariant;
begin
Result:=FWeight;
end;
function TDMFitter.Get_WeightType: Integer;
begin
Result:=FWeightType;
end;
function TDMFitter.Get_X: OleVariant;
begin
Result:=FX;
end;
function TDMFitter.Get_Y: OleVariant;
begin
Result:=FY;
end;
procedure TDMFitter.Set_Expression(Value: OleVariant);
begin
FExpression:=Value;
end;
procedure TDMFitter.Set_Iterations(Value: Integer);
begin
FIterations:=Value;
end;
procedure TDMFitter.Set_Options(Value: OleVariant);
begin
FOptions:=SetVariantArray(Value);
end;
procedure TDMFitter.Set_ParamCount(Value: Integer);
begin
FParamCount:=Value;
end;
procedure TDMFitter.Set_Parameters(Value: OleVariant);
begin
FParameters:=SetVariantArray(Value);
end;
procedure TDMFitter.Set_Sigmas(Value: OleVariant);
begin
FSigmas:=SetVariantArray(Value);
end;
procedure TDMFitter.Set_Weight(Value: OleVariant);
begin
FWeight:=SetVariantArray(Value);
end;
procedure TDMFitter.Set_WeightType(Value: Integer);
begin
FWeightType:=Value;
end;
procedure TDMFitter.Set_X(Value: OleVariant);
begin
if VarArrayDimCount(Value)=2 then
begin
FX:=Value; FXDimension:=VarArrayHighBound(Value, 2);
end else
begin
FX:=SetVariantArray(Value);
FXDimension:=0;
end;
end;
procedure TDMFitter.Set_Y(Value: OleVariant);
begin
FY:=SetVariantArray(Value);
end;
type
PLongWord=^LongWord;
IEnumVariant = interface(IUnknown)
['{00020404-0000-0000-C000-000000000046}']
function Next(celt: LongWord; var rgvar : OleVariant;
pceltFetched: PLongWord): HResult; stdcall;
function Skip(celt: LongWord): HResult; stdcall;
function Reset: HResult; stdcall;
function Clone(out Enum: IEnumVariant): HResult; stdcall;
end;
function SetVariantArray(const Value: variant): variant;
var
V: Variant;
OV: OleVariant;
pdisp: IDispatch;
punk: IUnknown;
pev: IEnumVariant;
I, N: integer;
const
NullPars: TDispParams=(rgvarg: nil; rgdispidNamedArgs: nil;
cArgs: 0; cNamedArgs: 0);
begin
Result:=Unassigned; if VarIsArray(Value)
then Result:=Value;
if VarIsType(Value, varDispatch) then begin
N:=Value.length; if N<1
then Exit;
pdisp:=Value;
OleCheck(pdisp.Invoke(-4, GUID_NULL, GetSystemDefaultLCID,
DISPATCH_METHOD, NullPars, @V, nil, nil));
Assert(VarIsType(V, varUnknown));
punk:=V;
pev:=punk as IEnumVariant;
OleCheck(pev.Reset);
Result:=VarArrayCreate([0, N-1], varVariant);
for I:=1 to N do
begin
OleCheck(pev.Next(1, OV, nil));
Result[I-1]:=OV;
end;
end;
end;
var
I: integer;
AC: array[0..15] of char;
initialization
TAutoObjectFactory.Create(ComServer, TDMFitter, Class_DMFitter,
ciMultiInstance, tmApartment);
for I:=1 to MaxCols do begin
StrPCopy(AC, 'cx'+IntToStr(I));
AddNLSFParserObject(@XVector[I], @AC, 4);
end;
end.