unit1.pas

Delphi 的数学控件

    WriteLn(OutF, Line2);
    WriteLn(OutF, 'Data file  : ', InFName);
    WriteLn(OutF, 'Study name : ', Title);
    WriteLn(OutF, 'x variable : ', XName);
    WriteLn(OutF, 'y variable : ', YName);
    WriteLn(OutF, 'Function   : ', FuncName);

    { Perform tests on parameters }
    ParamTest(B, V, N, FirstParam, LastParam, SB, T, Prob);

    WriteLn(OutF, Line1);
    WriteLn(OutF, 'Parameter    Est.value         Std.dev.        t Student       Prob(>|t|)');
    WriteLn(OutF, Line1);
    for I := FirstParam to LastParam do
      WriteLn(OutF, ParamName(I):5, B[I]:17:8, SB[I]:17:8, T[I]:17:2, Prob[I]:17:4);
    WriteLn(OutF, Line1);
    WriteLn(OutF, 'Number of observations            : n   = ', N:5);

    with Test do
      begin
        Sr := Sqrt(Vr);
        WriteLn(OutF, 'Residual error                    : s   = ', Sr:10:8);
        if (R2 >= 0.0) and (R2 <= 1.0) then
          WriteLn(OutF, 'Coefficient of determination      : r2  = ', R2:10:8);
        if (R2a >= 0.0) and (R2a <= 1.0) then
          WriteLn(OutF, 'Adjusted coeff. of determination  : r2a = ', R2a:10:8);
        Write(OutF, 'Variance ratio (explained/resid.) : F   = ', F:10:4);
        WriteLn(OutF, '    Prob(>F) = ', Prob:6:4);
      end;

    WriteLn(OutF, Line1);
    WriteLn(OutF, '  i        Y obs.       Y calc.      Residual      Std.dev.      Std.res.');
    WriteLn(OutF, Line1);
    for K := 1 to N do
      begin
        Delta := Y[K] - Ycalc[K];
        WriteLn(OutF, K:3, Y[K]:14:4, Ycalc[K]:14:4, Delta:14:4, S[K]:14:4, (Delta / S[K]):14:4);
      end;
    WriteLn(OutF, Line2);
    Close(OutF);
  end;

  procedure TForm1.Button2Click(Sender: TObject);
  { Perform fit }
  var
    U       : TMatrix;  { Matrix of independent variables (not used here) }
    Ycalc   : TVector;  { Expected Y values }
    S       : TVector;  { Standard deviations of Y values }
    CstPar  : TVector;  { Constant parameters }
    Theta   : TVector;  { Variance parameters }
    V       : TMatrix;  { Variance-covariance matrix of parameters }
    B_min,
    B_max   : TVector;  { Parameter bounds }
    RegTest : TRegTest; { Regression tests }
    ErrCode : Integer;  { Error code }
    I       : Integer;  { Loop variable }

  function Checked(CheckBox : TCheckBox) : Byte;
  { Get constant term flag }
  begin
    if CheckBox.Checked then
      Checked := 1
    else
      Checked := 0;
  end;

  begin
    { For the regression models defined in MODELS.PAS,
      the highest index of the constant parameters is 4}
    DimVector(CstPar, 4);

    { Read constant parameters if necessary.
      See the units defining the models (fitpol.pas etc) }
    case RegModel of
      REG_POL   : CstPar[0] := SpinEdit1.Value;
      REG_FRAC  : begin
                    CstPar[0] := SpinEdit1.Value;
                    CstPar[1] := SpinEdit2.Value;
                    CstPar[2] := Checked(CheckBox1);
                  end;
      REG_EXPO  : begin
                    CstPar[0] := SpinEdit1.Value;
                    CstPar[1] := Checked(CheckBox1);
                  end;
      REG_IEXPO : CstPar[0] := Checked(CheckBox1);
      REG_MINT  : begin
                    case RadioGroup1.ItemIndex of
                      0 : begin
                            CstPar[0] := StrToFloat(LabeledEdit10.Text);
                            CstPar[1] := StrToFloat(LabeledEdit11.Text);
                            CstPar[2] := 0.0;
                          end;
                      1 : begin
                            CstPar[0] := 0.0;
                            CstPar[1] := StrToFloat(LabeledEdit10.Text);
                            CstPar[2] := StrToFloat(LabeledEdit11.Text);
                          end;
                      2 : begin
                            CstPar[0] := StrToFloat(LabeledEdit10.Text);
                            CstPar[1] := 0.0;
                            CstPar[2] := StrToFloat(LabeledEdit11.Text);
                          end;
                    end;
                    CstPar[3] := StrToFloat(LabeledEdit12.Text);
                    CstPar[4] := Checked(CheckBox2);
                  end;
      REG_LOGIS : begin
                    CstPar[0] := Checked(CheckBox1);
                    CstPar[1] := Checked(CheckBox3);
                  end;
    end;

    { Initialize regression and variance models.
      Here we use a constant variance model }
    InitModel(RegModel, VAR_CONST, CstPar);

    { Dimension arrays.
      Note: the variance parameters Theta[1]..Theta[LastVarParam]
      must be supplied if we use a non-constant variance model }
    DimVector(Theta, LastVarParam);
    DimVector(B, LastParam);
    DimVector(B_min, LastParam);
    DimVector(B_max, LastParam);
    DimMatrix(V, LastParam, LastParam);
    DimVector(Ycalc, N);
    DimVector(S, N);

    { Initialize bounds }
    for I := FirstParam to LastParam do
      begin
        B_min[I] := -1.0E+6;
        B_max[I] :=  1.0E+6;
      end;

    { Perform regression. The numbers 1000 and 0.001 denote
      the maximal number of iterations and the tolerance on
      the fitted parameters }
    ErrCode := WLSFit(X, U, Y, N, True, 1000, 0.001, Theta,
                      B, B_min, B_max, V, Ycalc, S, RegTest);

    { Write results }
    case ErrCode of
      MAT_OK : begin
                 WriteOutputFile(InFName, OutFName, Title, XName, YName,
                                 N, Y, Ycalc, S, B, V, RegTest);
                 MessageDlg('Results written to file ' + OutFName,
                            mtInformation, [mbOk], 0);
               end;
      MAT_SINGUL   : MessageDlg('Singular matrix', mtError, [mbOk], 0);
      MAT_NON_CONV : MessageDlg('Non-convergence of SVD algorithm', mtError, [mbOk], 0);
    end;

    Calc := (ErrCode = 0);
  end;

  procedure TForm1.Button3Click(Sender: TObject);
  { Display results }
  begin
    Form1.Image1.Visible := False;
    Form1.RichEdit1.Visible := True;

    if OutFName <> '' then
      Form1.RichEdit1.Lines.LoadFromFile(OutFName);
  end;

  procedure ClearGraphic;
  begin
    with Form1.Image1 do
      Canvas.FillRect(Rect(0, 0, Width, Height));
  end;

  procedure GetGraphParam;
  { Read graphic parameters from dialog boxes }
  begin
    with Form1 do
      begin
        XAxis.Min  := StrToFloat(LabeledEdit1.Text);
        XAxis.Max  := StrToFloat(LabeledEdit2.Text);
        XAxis.Step := StrToFloat(LabeledEdit3.Text);

        YAxis.Min  := StrToFloat(LabeledEdit4.Text);
        YAxis.Max  := StrToFloat(LabeledEdit5.Text);
        YAxis.Step := StrToFloat(LabeledEdit6.Text);

        XAxis.Title := LabeledEdit7.Text;
        YAxis.Title := LabeledEdit8.Text;
        GraphTitle  := LabeledEdit9.Text;

        CurvParam.LineParam.Color  := ColorBox1.Selected;
        CurvParam.PointParam.Color := ColorBox1.Selected;

        Npts := SpinEdit3.Value;
      end;
  end;

  function Func(X : Float) : Float;
  { Function to be plotted }
  begin
    Func := RegFunc(X, B);
  end;

  procedure PlotGraph(Canvas : TCanvas);
  begin
    PlotXAxis(Canvas);
    PlotYAxis(Canvas);
    PlotGrid(Canvas);
    WriteTitle(Canvas);

    PlotCurve(Canvas, X, Y, 1, N, CurvParam);

    if Calc then
      PlotFunc(Canvas, Func, XAxis.Min, XAxis.Max,
               Npts, CurvParam.LineParam);
  end;

  procedure TForm1.Button4Click(Sender: TObject);
  { Plot graph }
  begin
    if N = 0 then Exit;

    Form1.Image1.Visible := True;
    Form1.RichEdit1.Visible := False;

    ClearGraphic;
    GetGraphParam;
    InitGraph(Image1.Canvas, Image1.Width, Image1.Height);
    PlotGraph(Image1.Canvas);
  end;

  procedure TForm1.Button5Click(Sender: TObject);
  { Print curve }
  begin
    if N = 0 then Exit;
    Printer.BeginDoc;
    GetGraphParam;
    InitGraph(Printer.Canvas, Printer.PageWidth, Printer.PageHeight);
    PlotGraph(Printer.Canvas);
    Printer.EndDoc;
  end;

  procedure TForm1.Button6Click(Sender: TObject);
  { Quit program }
  begin
    Form1.Close;
  end;

begin
  N := 0;
  OutFName := '';
  RegModel := REG_LIN;

  { Initialize graphic parameters }
  Xwin1 := 10;
  Xwin2 := 90;
  Ywin1 := 10;
  Ywin2 := 90;

  CurvParam.LineParam.Color   := clRed;
  CurvParam.LineParam.Style   := psSolid;
  CurvParam.LineParam.Width   := 1;
  CurvParam.PointParam.Color  := clRed;
  CurvParam.PointParam.Symbol := 1;
  CurvParam.PointParam.Size   := 2;
  CurvParam.Step              := 1;
  CurvParam.Connect           := False;
end.