unitfp.pas

一个多元非线性回归分析源码以及其中的公式列表

unit UnitFP;

interface

  uses
     Forms, SysUtils, windows, Compile_Hss, DBClient, RunExe_Hss, math,
     DB, Variants;

  type TabcList=record         //注意 比 TParameterList 多了几个域
    CName     :String;     //参数名称
    CAddress  :PExtended;  //参数地址
    IfConst   :boolean;    //是否为常数  false:常数 true:变量  (没有用，这里全部为false)
    PType     :integer;    //参数类型   整数、浮点、常数
    MinV      :extended;   //最小值
    MaxV      :extended;   //最大值
    Default   :extended;   //默认值
    Precision :integer;    //网格精度
  end;

  type TPDList=record
    CName     :String;     //变元名称
    CAddress  :PExtended;  //变元地址
    Index     :integer;    //变元序号
  end;

  const  DataLength:integer=100;
  const  DataMaxIndex:integer=20;
  var
    Compile   :TCompile;     //编译执行函数
    abcList   :array of TabcList;       //拟合函数中的 参数
    PDList    :array of TPDList; //拟合函数中的 变元
    dData     :array of array of Extended;  //变元数据矩阵

    NowTime   :Extended;          //当前时间 
    runPause  :boolean;

    ApWay     :integer;        //当前拟合方法
    FBWay     :integer;        //当前 拟合 优劣 检验 标准

    ExpressionType :integer;   // -1..DataLength-1 //表达式方式  意义 -1: 0=f() ; N(0-DataLength-1): dN=f() ;
    ExpressionTypeLR :integer; //意义 -1: 0=f(); 0: dN=f() ; 1: f()=dN ;


    dMax        :extended;           //当前最好优化值
    abcMax      :array of extended;  //当前最好参数

    ClientDataSetDataOld: TClientDataSet;   //当前数据源
    ClientDataSetDataOldTemp :TClientDataSet; //临时保存数据用
    ClientDataSetData: array  of TClientDataSet;

  procedure FieldDefsAssign(var cdX : TClientDataSet);  //生成字段名
  
  function  GetEQ(const str:string;var FirstEQIndex:integer):integer;  // 返回表达式中有几个等号
  function  IFIn(const F:string;const Af:array of string):boolean;   // F 是否在 字符串数组中 (不区分大小写)
  function  IFInDCount(const F:string):boolean;    // F 是否在 'd0'...... 中 (不区分大小写)
  function  strFind(const StrT1,StrT2:string;var index:integer):boolean; //在StrT1中是否有 标识符 StrT2

  function  GetdData(DdataSet:TClientDataSet;var iCount:integer):boolean;    //获取实验数据
  function  GetabcData(abcDataSet:TClientDataSet):boolean;//获取设置好的参数性质

  function  GetFBValue(const cList :array of TabcList;const HowFBWay:integer=-1):Extended;//根据传来的参数具体值,计算返回 优劣 值

  procedure GetSubValue(const cList :array of TabcList;const pArray :array of extended;var dSubArray:array of extended);overload; //
  function  GetSubValue(const cList :array of TabcList;const pArray :array of extended;const x:extended;const index0,index1:integer):extended;overload;
  
  procedure RunOptimize();
  procedure RunOptimize0();
  procedure RunOptimize1();
  procedure RunOptimize2();
  procedure RunOptimize3();
  procedure RunOptimize4();

  
  function MaxInArray(const Data: array of Extended): Extended;
  function MinInArray(const Data: array of Extended): Extended;

  function Sgn(const x:extended):integer;
  
  function  GetKeyValue(const sKey:string):extended;

  function  GetDataAsStr(const sDataSet: TClientDataSet):string;
  function  GetStrFeildValue(var s:string):variant;
  procedure SetDataAsStr(var sDataSet: TClientDataSet;const sData: string;const CellX:integer=0);

implementation

uses  UnitAuto;

function Sgn(const x:extended):integer;
begin
  if x>0 then
    result:=1
  else if x<0 then
    result:=-1
  else
    result:=0;
end;

function  GetEQ(const str:string;var FirstEQIndex:integer):integer;  // 返回表达式中有几个等号
var
  i     :integer;
  strT1 :string;
  strT2 :string;

  function  DelNil(const str0:string):string;
  var
    i     :integer;
  begin
    result:='';
    for i:=1 to length(str0) do
    begin
      case str0[i] of
        ' ',#13,#10,#9: result:=result;
        else result:=result+str0[i];
      end;
    end;
  end;

begin
  result:=0;
  FirstEQIndex:=0;
  for i:=length(str) downto 1 do
  begin
    if str[i]='=' then
    begin
      inc(result);
      FirstEQIndex:=i;   //返回第一个'='的位置
    end;
  end;
  if result=0 then
  begin
    ExpressionType:=-1;
    ExpressionTypeLR:=-1;
  end
  else if result=1 then
  begin
    strT1:=uppercase(copy(str,1,FirstEQIndex-1));
    strT1:=DelNil(strT1);
    strT2:=uppercase(copy(str,FirstEQIndex+1,length(str)-FirstEQIndex));
    strT2:=DelNil(strT2);
    if (strT1='0') or (strT2='0') then
    begin
      ExpressionType:=-1;
      ExpressionTypeLR:=-1;
    end
    else if (IFInDCount(strT1)) and (not(strFind(StrT2,StrT1,i)))then
    begin
      ExpressionType:=strtoint(copy(strT1,2,length(strT1)-1));
      ExpressionTypeLR:=0;
    end
    else if (IFInDCount(strT2)) and(not( strFind(StrT1,StrT2,i))) then
    begin
      ExpressionType:=strtoint(copy(strT2,2,length(strT2)-1));
      ExpressionTypeLR:=1;
    end
    else
    begin
      ExpressionType:=-1;
      ExpressionTypeLR:=-1;
    end;
  end;

end;

function MaxInArray(const Data: array of Extended): Extended;
var
  I: Integer;
begin
  Result := Data[Low(Data)];
  for I := Low(Data) + 1 to High(Data) do
    if Result < Data[I] then  Result := Data[I];
end;

function MinInArray(const Data: array of Extended): Extended;
var
  I: Integer;
begin
  Result := Data[Low(Data)];
  for I := Low(Data) + 1 to High(Data) do
    if Result > Data[I] then  Result := Data[I];
end;

procedure FieldDefsAssign(var cdX : TClientDataSet);  //生成字段名
var
  i:integer;
begin
  cdX:=TClientDataSet.Create(nil);
  cdX.AfterScroll:=frmMain.ClientDataSetDataAfterScroll;
  cdX.AfterPost:=frmMain.ClientDataSetDataAfterPost;
  cdX.AfterDelete:=frmMain.ClientDataSetDataAfterDelete;
  cdX.AfterClose:=frmMain.ClientDataSetDataAfterClose;
  for i:=0 to DataLength-1 do
  begin
    cdX.FieldDefs.Add('d'+inttostr(i),ftFloat);
  end;
  cdX.CreateDataSet;
end;

function IFIn(const F:string;const Af:array of string):boolean;
var
  i   :integer;
begin
  result:=false;
  for i:=Low(Af) to High(Af) do
  begin
    if uppercase(F)=uppercase(Af[i]) then
    begin
      result:=true;
      exit;
    end;
  end;
end;

function IFInDCount(const F:string):boolean;
var
  s   :string;
  i   :integer;
  Af  :array of string;
begin
  try
    s:=uppercase(f) ;
    case length(s) of
      0:  result:=false;
      1:  result:=false;
      2,3..10:
        begin
          setlength(af,DataLength);
          for i:=0 to DataLength-1 do
          begin
            af[i]:=inttostr(i);
          end;
          if (s[1]='D') and (ifin(copy(s,2,length(s)-1),af)) then
            result:=true
          else
            result:=false;
        end;
      else
        result:=false;
    end;
  except
    result:=false;
  end;
end;

function GetdData(DdataSet:TClientDataSet;var iCount:integer):boolean;
var
  i,nloop  :integer;
begin
  try
    DdataSet.Last;
    DdataSet.First;
    iCount:=DdataSet.RecordCount;
    if not (iCount<0) then
    begin
      setlength(dData,iCount);
      for i:=0 to iCount-1 do
        setlength(dData[i],DataLength);
      i:=0;
      while not (DdataSet.Eof) do
      begin
        for nloop:=0 to DataLength-1 do
        begin
          dData[i,nloop]:=DdataSet.FieldByName('d'+inttostr(nloop)).asfloat;
        end;
        DdataSet.Next;
        i:=i+1;
      end;
      DdataSet.First;
      result:=true;
    end
    else
      result:=false;
  except
    result:=false;
  end;
end;

function GetabcData(abcDataSet:TClientDataSet):boolean;
var
  i   :integer;
  dTemp :extended;
begin
  try
    for i:=low(abcList) to high(abcList) do
    begin
        abcDataSet.First;
        while not(abcDataSet.Eof) do
        begin
          if (abcDataSet.FieldByName('F_TP_NAME').AsString=abcList[i].CName) then
            break
          else
           abcDataSet.Next;
        end;

        abcList[i].PType:=abcDataSet.FieldByName('F_TP_ZF_ID').AsInteger;
        abcList[i].MinV:=abcDataSet.FieldByName('F_TP_MIN').AsFloat;
        abcList[i].MaxV:=abcDataSet.FieldByName('F_TP_MAX').AsFloat;;
        abcList[i].Default:=abcDataSet.FieldByName('F_TP_DEFAULT').AsFloat;;
        abcList[i].Precision:=abcDataSet.FieldByName('F_TP_Precision').AsInteger;;
     end;
     abcDataSet.First;


     for i:=low(abcList) to high(abcList) do
     begin

       if (abcList[i].PType=2) then
       begin
         abcList[i].MinV:=trunc(abcList[i].MinV);
         abcList[i].MaxV:=trunc(abcList[i].MaxV);
       end
       else if (abcList[i].PType=3) then
       begin
         abcList[i].MinV:=abcList[i].Default;
         abcList[i].MaxV:=abcList[i].Default;
         abcList[i].Precision:=1;
       end;

       if (abcList[i].MaxV=abcList[i].MinV) then
       begin
         abcList[i].Default:=abcList[i].MaxV;
       end;

       
       abcList[i].Precision:=abs(abcList[i].Precision);
       if abcList[i].Precision<1 then abcList[i].Precision:=2;
       
       if abcList[i].MaxV<abcList[i].MinV then
       begin
         dTemp:= abcList[i].MaxV;
         abcList[i].MaxV:=abcList[i].MinV;
         abcList[i].MinV:=dTemp;
       end;
     end;

     result:=true;
  except
    result:=false;
  end;
end;

function GetFBValue(const cList :array of TabcList;const HowFBWay:integer=-1):Extended;//越小越好//根据传来的参数具体值,计算返回 优劣 值
var
  i,j     :integer;
  sum     :extended;
  dVMax   :extended;
  dVMin   :extended;
  dV      :extended;
  dVvar   :array of Extended;
  L       :integer;
  dVP     :Extended;
  MyFBWay :integer;
  Temp    :double;
begin
  sum:=0;
  for i:=low(cList) to high(cList) do    //参数赋值
  begin
    cList[i].CAddress^:=cList[i].Default;
  end;
  if HowFBWay=-1 then
    myFBWay:=FBWay
  else
    myFBWay:=HowFBWay;
  try
    case myFBWay of
      0:   //方差最小  , 返回 方差
      begin       
        sum:=0;
        for i:=low(dData) to high(dData) do
        begin
          for j:=low(PDList) to high(PDList) do
            PDList[j].CAddress^:=dData[i,PDList[j].Index];

          Compile.GetValue(dV);
          Sum:=Sum+dV*dV;
        end;
      end;
      1:   // 差的绝对值和最小 ,返回 差的绝对值的和
      begin
        sum:=0;
        for i:=low(dData) to high(dData) do
        begin
          for j:=low(PDList) to high(PDList) do
            PDList[j].CAddress^:=dData[i,PDList[j].Index];

          Compile.GetValue(dV);
          Sum:=Sum+abs(dV);
        end;
      end;
      2:   // 差的绝对值最大者最小 ,返回 差的绝对值最大者
      begin
        sum:=0;
        for i:=low(dData) to high(dData) do
        begin
          for j:=low(PDList) to high(PDList) do
            PDList[j].CAddress^:=dData[i,PDList[j].Index];

          Compile.GetValue(dV);
          dV:=abs(dV);
          if dV>sum then sum:=dV;
        end;
      end;