线性规划法（解线性方程组），如何？ (200分)

  • 主题发起人 主题发起人 山木人
  • 开始时间 开始时间
山

山木人

Unregistered / Unconfirmed
GUEST, unregistred user!
很难...
近日为解决"集料配合比"需用到线性规划法解线性方程组，但没有合适的算法。
百思不得其解，数据如下，谁能解决这个数学问题，请给出求解任意阶任意元Function：

A X = B
己知：
　A[0,0]:=74.5
A[0,1]:=100.0
A[0,2]:=100.0
A[0,3]:=100.0
A[0,4]:=100.0;
A[1,0]:=29.5
A[1,1]:=98.1
A[1,2]:=100.0
A[1,3]:=100.0
A[1,4]:=100.0;
A[2,0]:=0.7
A[2,1]:=55.6
A[2,2]:=100.0
A[2,3]:=100.0
A[2,4]:=100.0;
A[3,0]:=0
A[3,1]:=0
A[3,2]:=99.6
A[3,3]:=100.0
A[3,4]:=100.0;
A[4,0]:=0
A[4,1]:=0
A[4,2]:=61.7
A[4,3]:=60.2
A[4,4]:=100.0;
A[5,0]:=0
A[5,1]:=0
A[5,2]:=32.4
A[5,3]:=31.9
A[5,4]:=100.0;
A[6,0]:=0
A[6,1]:=0
A[6,2]:=20.4
A[6,3]:=20.9
A[6,4]:=100.0;
A[7,0]:=0
A[7,1]:=0
A[7,2]:=0
A[7,3]:=11.9
A[7,4]:=100.0;
A[8,0]:=0
A[8,1]:=0
A[8,2]:=0
A[8,3]:=8.1
A[8,4]:=97.0;
A[9,0]:=0
A[9,1]:=0
A[9,2]:=0
A[9,3]:=5.3
A[9,4]:=88.0;

B[0]:=95
B[1]:=71
B[2]:=57.5
B[3]:=35
B[4]:=25

B[5]:=17.5
B[6]:=13
B[7]:=9.5
B[8]:=7
B[9]:=5;

求解：
X[0];X[1];X[2];X[3];X[4];

不知用最小二乘法能否解决，在论坛托福得到最小二乘法解线性方程组的源程序:
http://www.delphibbs.com/delphibbs/dispq.asp?lid=524801
但本人才疏学浅，不知道如何调用。还望详解，谢谢！
 
你需要学习一下《运筹学》 高校教材
 
我的毕业设计其中一个小程序给你参考一下
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, Grids, Mask, ComCtrls, TeEngine, Series,
ExtCtrls, TeeProcs, Chart, OleCtrls, vcfi, Spin, Menus,printers;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
Label1: TLabel;
Label2: TLabel;
saveB: TBitBtn;
ReadB: TBitBtn;
SaveDialog1: TSaveDialog;
OpenDialog1: TOpenDialog;
Bevel1: TBevel;
Label4: TLabel;
Bevel2: TBevel;
Bevel3: TBevel;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
BitBtn1: TBitBtn;
Label3: TLabel;
Label5: TLabel;
Label6: TLabel;
Edit1: TEdit;
SEdit1: TSpinEdit;
SEdit2: TSpinEdit;
Label7: TLabel;
SEdit3: TSpinEdit;
checkBox1: TCheckBox;
Label8: TLabel;
minEdit: TSpinEdit;
maxEdit: TSpinEdit;
BitBtn3: TBitBtn;
CheckBox2: TCheckBox;
TabSheet3: TTabSheet;
BitBtn4: TBitBtn;
CheckBox3: TCheckBox;
Edit2: TEdit;
Edit3: TEdit;
Label10: TLabel;
Label11: TLabel;
Panel1: TPanel;
Label9: TLabel;
StringGrid2: TStringGrid;
SpinEdit1: TSpinEdit;
Panel2: TPanel;
Label12: TLabel;
StringGrid3: TStringGrid;
SpinEdit2: TSpinEdit;
CheckBox4: TCheckBox;
CheckBox5: TCheckBox;
savea: TBitBtn;
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
FontDialog1: TFontDialog;
ColorDialog1: TColorDialog;
MCheckBox: TCheckBox;
PrintDialog1: TPrintDialog;
print: TBitBtn;
delete: TBitBtn;
PopupMenu2: TPopupMenu;
ENTER1: TMenuItem;
ENTER2: TMenuItem;
N10: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
N11: TMenuItem;
D1: TMenuItem;
S1: TMenuItem;
L1: TMenuItem;
CheckBox6: TCheckBox;
Memo1: TMemo;
Memo2: TMemo;
N8: TMenuItem;
help2: TMenuItem;
N9: TMenuItem;
H1: TMenuItem;
N12: TMenuItem;
inrow: TMenuItem;
incol: TMenuItem;
delrow: TMenuItem;
delcol: TMenuItem;
N13: TMenuItem;
search: TMenuItem;
searchnext: TMenuItem;
FindDialog1: TFindDialog;

procedure SEdit1Change(Sender: TObject);
procedure SEdit2Change(Sender: TObject);
procedure saveBClick(Sender: TObject);
procedure ReadBClick(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure SEdit3Change(Sender: TObject);
procedure PageControl1Change(Sender: TObject);
procedure BitBtn3Click(Sender: TObject);
procedure SpinEdit1Change(Sender: TObject);
procedure SpinEdit2Change(Sender: TObject);
procedure CheckBox3Click(Sender: TObject);
procedure CheckBox4Click(Sender: TObject);
procedure BitBtn4Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure saveaClick(Sender: TObject);
procedure N1Click(Sender: TObject);
procedure N2Click(Sender: TObject);
procedure N4Click(Sender: TObject);
procedure N5Click(Sender: TObject);
procedure Memo1DblClick(Sender: TObject);
procedure printClick(Sender: TObject);
procedure deleteClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject
var CanClose: Boolean);
procedure ENTER1Click(Sender: TObject);
procedure ENTER2Click(Sender: TObject);
procedure N6Click(Sender: TObject);
procedure N7Click(Sender: TObject);
procedure help2Click(Sender: TObject);
procedure Memo2KeyDown(Sender: TObject
var Key: Word;
Shift: TShiftState);
procedure StringGrid1SelectCell(Sender: TObject
Col, Row: Integer;
var CanSelect: Boolean);
procedure StringGrid1Exit(Sender: TObject);
procedure Memo2Exit(Sender: TObject);
procedure StringGrid1KeyPress(Sender: TObject
var Key: Char);
procedure inrowClick(Sender: TObject);
procedure incolClick(Sender: TObject);
procedure delrowClick(Sender: TObject);
procedure delcolClick(Sender: TObject);
procedure H1Click(Sender: TObject);
procedure searchClick(Sender: TObject);
procedure FindDialog1Find(Sender: TObject);
procedure searchnextClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
down,coll,roww,fz:integer;
sendb,senda:boolean;

implementation

uses Unit2;

{$R *.DFM}



procedure TForm1.SEdit1Change(Sender: TObject);
var i:integer;
begin
try
StringGrid1.rowCount:=Sedit1.value+1;
for i:= 1 to Sedit1.value+1 do
if StringGrid1.cells[0,i]='' then
StringGrid1.cells[0,i]:='数据'+inttoStr(i);
except showmessage('样本个数不能为空!')
end;
//if sedit1.value<sedit2.Value then Showmessage('变量个数必须小于样本个数')
end;

procedure TForm1.SEdit2Change(Sender: TObject);
var i:integer;
begin
if sedit3.value<sedit2.Value then
try
StringGrid1.colCount:=sedit2.value+1;
StringGrid2.colCount:=sedit2.value;
StringGrid3.colCount:=sedit2.value;
for i:= 1 to Sedit3.value do
if optionform.stringgrid2.Cells[1,i]='' then
StringGrid1.cells[i,0]:='Y_'+inttoStr(i);
for i:= 1 to Sedit2.value-Sedit3.value do
if StringGrid1.cells[i+Sedit3.value,0]='' then
begin
StringGrid1.cells[i+Sedit3.value,0]:='X_'+inttoStr(i);
StringGrid2.cells[i,0]:='x_'+inttoStr(i);
StringGrid3.cells[i,0]:='x_'+inttoStr(i);
end;
except messagebox(0,'变量个数不能为空!','Error',mb_OK );
end;// else messagebox(0,'因变量个数必须小于变量个数！','mterror',mb_OK);
// if sedit1.value<sedit2.Value then Showmessage('变量个数必须小于样本个数');
end;

procedure TForm1.SEdit3Change(Sender: TObject);
var i:integer;
begin
if sedit3.value<sedit2.Value then begin
for i:=1 to sedit3.value do
stringgrid1.cells[i,0]:='Y_'+inttostr(i);
for i:=sedit3.value+1 to sedit2.value do
stringgrid1.cells[i,0]:='X_'+inttostr(i-sedit3.value);
end
else begin
showmessage('因变量个数必须小于变量个数！');
sedit3.value:=sedit3.value-1;
end;
end;

procedure TForm1.saveBClick(Sender: TObject);
Var savefile:Textfile;//file of String;
i,j,row,col,b,line:integer;
val:single;filename,name:string;
begin
savedialog1.filterindex:=1;
row:=Sedit1.value;
col:=sedit2.value;
for i:=1 to col do
begin
for j:=1 to row do
if stringgrid1.cells[i,j]='' then
case
messagedlg('第'+inttostr(j)+'行第'+inttostr(i)+'列数据为空，要修改吗？',
mtConfirmation,[mbYes,mbNo,mbCancel],0)
of id_Yes:begin stringgrid1.col:=i;stringgrid1.row:=j;exit;end;
id_No:begin b:=1;break;end;
// id_cancel:false;
end;
if b=1 then begin b:=0;break;end;
end;

if savedialog1.execute then
begin
AssignFile(savefile,savedialog1.filename);
rewrite(savefile);
writeln(savefile,sedit1.value)
//写入结构
writeln(savefile,sedit2.value);
for i:=1 to col do //写入数据,按列写入文件
for j:=0 to row do //注意：cell 的i为列,j为行
writeln(savefile,stringGrid1.cells[i,j]);


for j:=0 to row do
writeln(savefile,stringGrid1.cells[0,j]);
writeln(savefile,'');
writeln(savefile,'备注');
for Line := 0 to Memo2.Lines.Count - 1 do
Writeln(savefile, Memo2.Lines[Line]);
closefile(savefile);
saveb.enabled:=false;
s1.Enabled:=false;
end
else sendb:=false


end;//do nothing;


procedure TForm1.ReadBClick(Sender: TObject);
Var loadfile:Textfile;//file of String;
i,j,row,col:integer;
str,name,filename:string;
begin
if saveb.enabled then
begin
case MessageDlg('数据表中数据已改变，是否要保存？', mtConfirmation,
[mbYes, mbNo,mbCancel], 0) of { produce the message dialog box }
id_Yes:begin saveBClick(Sender);exit;end { yes means user wants to save }
id_Cancel: exit
{ if user Cancels, exit dialog but don't close form }
id_no:;
end;
end;
if opendialog1.execute then
begin
memo2.lines.clear;
AssignFile(loadfile,opendialog1.filename);
reset(loadfile);
readln(loadfile,str)
//读入结构
Sedit1.value:=strtoint(Str);
row:=Sedit1.value;
StringGrid1.RowCount:=row+1;
readln(loadfile,str);
Sedit2.value:=strtoint(Str);
col:=Sedit2.value;
StringGrid1.colCount:=col+1;

for i:=1 to col do //按列读入数据文件
for j:=0 to row do //注意：cell[i,j] 的i为列 j为行
begin
readln(loadfile,str);
stringGrid1.cells[i,j]:=Str;
end;
if not Eof(loadfile) then
for j:=0 to row do
begin
readln(loadfile,str);
stringGrid1.cells[0,j]:=Str;
end;

while not eof(loadfile) do
begin
readln(loadfile,str);
if str='备注' then
while not eof(loadfile) do
begin
str:='';
readln(loadfile,str);
memo2.lines.add(str);
end;
end

delete.enabled:=true;
d1.enabled:=true;
sz:=1;
closefile(loadfile);
end;

end;

//*********以下为回归分析的具体过程 **********
procedure TForm1.BitBtn1Click(Sender: TObject);
label 2410,2900,6100,1,2;
const
nn=50;
mm=200;
type number=array[1..nn] of integer;
stri= array[1..nn] of string;
olddata=array[1..nn] of single;
var
nya,nyb,n,m,l1,i,j,nyb1,nyang,l,nx,ny,nas,cij,iyn,jyn,nm,
iyaa,iya2,iya1,iya3,iyti,iyt2,i8,i3,i2,i1,m1,n6,i6,i0,
n7,n8,i7,ka,j1,kb,m2,my,dm,di,k1,k2,k,IY25,ix,jxx,mx,ixx,ijxx:integer;
p2,d,a,p,p0,mp,r2,s1,ms1,mr,f,s2,ms,mf,yw,yq,
x,dy,py,mpy,mr2,mr1,MRI,eps5,eps6,mr11,mrii : single;
str,str1,BB,strx,tempstrx:string;

r:array[1..5000] of single;
rr,v1,vvi:array[1..mm,1..nn] of single;//v1[] save the data
vv,sx:array[1..nn] of string;
n5:array[1..mm] of integer;
cx:array[0..nn] of single;
iy4,iy5,xx,dx,vi,g1,v:olddata;
nyan:number;

function f525(iyn,jyn:integer):integer;
var cij1,ijyn:integer;
begin
CIJ:=1;
CIJ1:=iyn+1;
IF(JYN<>0) THEN
FOR IJYN:=1 TO jyn do
begin
CIJ1:=CIJ1-1;
CIJ:=round(CIJ/IJYN*CIJ1);
END;// IJYN
result:=cij;
end;

procedure p461(var nyb1:integer;var nyan:number);//n1-nyb1,nan-nyan
var i,iyn,jyn:integer;
begin
FOR I:=1 TO NYB do
begin
IYN:=N-L1+I;
JYN:=I;
cij:=f525(iyn,jyn);
NYAN:=L1-1+CIJ;
//memo1.lines.add(inttoStr(i)+' : '+inttoStr(IYN)+','+inttoStr(jYN)+' : '+floatToStr(cij));//Test it
END;// I
// IF(NYAN[NYA]-L1+1>M OR NYA>NYB) GOTO 3710
NYB1:=NYB
while (NYAN[NYB1]-L1+1>M) do
NYB1:=NYB1-1

end;

procedure p480(var v:olddata);
var
iyaa,an,iya3,iyt2,iyti,l11,iya1,iya2,i:integer;
begin
FOR IYAA:=2 TO NYANG do
begin
jYN:=IYAA-1;
IYN:=NYAN[1]-L1-1+IYAA;
cij:=f525(iyn,jyn);
IYT2:=CIJ+L1-1;
IYA2:=IYT2;
IYTI:=CIJ+L1
an:=nyan[1];
l11:=l1+1;
FOR I:=L11 TO an do
begin
JYN:=IYAA-1
IYN:=NYAN[1]-I-1+IYAA;
cij:=f525(iyn,jyn);
IYA3:=IYTI-CIJ;
FOR IYA1:=IYA3 TO IYT2 do
begin
IYA2:=IYA2+1;
V[IYA2]:=V*V[IYA1];
// memo1.lines.add('V*V[IYA1]=floattostr(V)*floattostr(V[IYA1]');
// memo1.lines.add(floattostr(V)+' * '+floattostr(V[IYA1])+' = '+floattostr(V[IYA2]));
END;// IYA1
END;// I
END;// IYAA

end;

begin //main procedure
memo1.lines.clear;
if ((Sedit1.text='')or (Sedit2.text='')) or ((Sedit3.text='')or (edit1.text=''))
then
begin
Showmessage('请先输入观测值个数和变量个数');
exit
end else
begin
m:=Sedit1.value
//观测值个数 行
n:=Sedit2.value
//变量个数即列
nm:=n;
l1:=Sedit3.value
//因变量个数
p2:=StrTofloat(edit1.text);//精度控制
if p2<1000 then begin Showmessage('精度过低!!!');
edit1.setfocus;exit;end;
nya:=minedit.value
//最小方次
nyb:=maxedit.value
//最大方次
if n<=l1 then
begin
showmessage('因变量个数必须小于变量个数');
sedit3.setfocus;
exit;
end;
if sedit1.value<sedit2.value then
begin
showmessage('变量个数必须小于样本数');
sedit1.setfocus;
exit;
end;
if nya>nyb then
begin
showmessage('最大方次小于最小方次,重输！');
maxedit.setfocus;
exit;
end;
for i:= 1 to n do
for j:= 1 to m do
if StringGrid1.cells[i,j]='' then
begin
showmessage('第'+inttoStr(j)+'行,第'+inttoStr(i)+'列数据为空!');
stringgrid1.setfocus;
stringgrid1.col:=i;
stringgrid1.row:=j;
exit;
end
else try
v1[j,i]:=Strtofloat(StringGrid1.cells[i,j]);
except
showmessage('第'+inttoStr(j)+'行,第'+inttoStr(i)+'列数据非法!');
stringgrid1.setfocus;
stringgrid1.col:=i;
stringgrid1.row:=j;
exit;
end;
end
//以上if else end;21行判断数据是否有误!public

memo1.lines.add(' *************************************');
memo1.lines.add(' * 多 元 线 性 回 归 计 算 结 果 *');
memo1.lines.add(' *************************************');
memo1.lines.add('(1)基 本 参 数');
memo1.lines.add('---------------');
memo1.lines.add('样 品 数: '+inttoStr(m));
memo1.lines.add('自 变 量 数: '+inttoStr(n));
memo1.lines.add('');
if checkbox6.checked then
begin
memo1.lines.add('------------原始数据----------');
memo1.Lines.add('');
str:='';
for i:=0 to sedit2.value do
str:=str+stringgrid1.Cells[i,0]+' ';
memo1.lines.add(str);
str:='';
for i:= 1 to m do
begin
str:=stringgrid1.cells[0,i]+' ';
FOR J:=1 TO n do
str:=str+format('%9.7g',[V1[I,J]]);//,ffgeneral,5,5);
memo1.Lines.add(str);
str:='';
end;//FOR I:=1 TO N
end;//if checkbox1.checked
memo1.lines.add('');
memo1.lines.add('');

p461(nyb1,nyan);//1180
N:=NYAN[NYB1];
NAS:=NYAN[1]-L1;
FOR I:=1 TO L1 do
VV:='';
FOR I:=1 TO NAS do
VV[I+L1]:=('X'+inttoSTR(I));
FOR IYAA:=2 TO NYB1 do //4480
begin
JYN:=IYAA-1;
IYN:=NYAN[1]-L1-1+IYAA;
cij:=f525(iyn,jyn);
IYT2:=CIJ+L1-1;
IYA2:=IYT2;
IYTI:=CIJ+L1;
FOR I:=L1+1 TO NYAN[1] do
begin
JYN:=IYAA-1;
IYN:=NYAN[1]-I-1+IYAA;
cij:=f525(iyn,jyn);
IYA3:=IYTI-CIJ;
FOR IYA1:=IYA3 TO IYT2 do
begin
IYA2:=IYA2+1;
VV[IYA2]:=(VV+'*'+VV[IYA1]);
END;// IYA1
END;// I
END;// IYAA
//END 4480

FOR NYANG:=NYA TO NYB1 DO
BEGIN
N:=NYAN[NYANG];
L:=round(N*(N+1)/2);
NX:=N+1
NY:=round(NX*(NX+1)/2);
I8:=0;
FOR I1:=1 TO N DO
G1[I1]:=0;
FOR I1:=1 TO L do
R[I1]:=0;
FOR I1:=1 TO M do
begin
FOR I:=1 TO NYAN[1] do
V:=V1[I1,I]
IF(NYANG<>1) then
p480(v);
N6:=0 //1380
FOR I2:=1 TO N do
begin
D:=V[I2];
G1[I2]:=G1[I2]+D;
FOR I3:=I2 TO N do
begin
N6:=N6+1;
R[N6]:=R[N6]+V[I3]*D;
END;// I3
END;// I2

END;// I1


N6:=1;
A:=1/M;
memo1.lines.add(' '+inttostr(nyang)+'次方差分析表');
memo1.lines.add('-------------------------------------');
//PRINT TAB[30];NYANG;"次方差分析表"
FOR I1:=1 TO N do
begin
P:=R[N6]-G1[I1]*G1[I1]*A;
M1:=M-1;
IF(I1<=L1) then
begin
MP:=P;
str:='第'+inttostr(I1)+'应变量: '+'总 自由度: '+inttostr(m1);
str:=str+' 总平房和: '+floattostrf(mp,fffixed,6,6);//SA1$;SA3$;M1;TAB[32];SA1$;SA2$;MP
memo1.lines.add(str);
memo1.lines.add('');
end;//IF(I1<L1)
V[I1]:=0;
P0:=1/SQRT(P2);
IF (P<=P0) then
begin
R[N6]:=1;
N6:=N6+N+1-I1;
end
else// IF(P<=P0)
begin
V[I1]:=1/SQRT(P);
r[N6]:=1;
N6:=N6+N+1-I1;
end;
END;// I1
N6:=1
FOR I1:=1 TO N do
begin
D:=A*G1[I1];
P:=V[I1];
N6:=N6+1;
G1[I1]:=D;
I6:=I1+1;

FOR I2:=I6 TO N do
begin
R[N6]:=(R[N6]-D*G1[I2])*V[I2]*P;
N6:=N6+1;
END;// I2
end;//i1
memo1.lines.add('');
if checkbox1.Checked=true then
begin
memo1.lines.add(' ------------ 逆阵(下三角)-------');
str:='';
k:=1
for i:=1 to nyan[nyang] do
for j:=i to nyan[nyang] do
begin
rr[i,j]:=r[k];
rr[j,i]:=rr[i,j];
k:=k+1;
end;
for i:=1 to nyan[nyang] do
begin
for j:=1 to i do
if rr[i,j]<0 then
str:=str+' '+floattostrF(rr[i,j],fffixed,5,5)
else
str:=str+' '+floattostrF(rr[i,j],fffixed,6,6);
memo1.Lines.add(str);
str:='';
end;
memo1.lines.add('');

end;//if checkbox checked
I1:=-N;
I2:=N+1;
FOR I3:=1 TO N do
begin
I1:=I1+I2-I3;
N5[I3]:=I1;
END;// I3
I0:=L1+1
FOR I1:= I0 TO N do
begin
N6:=N5[I1];
IF(V[I1]=0) then
begin
P:=0
I8:=I8+1;
R[N6+I1]:=0;
GOTO 2410;
end //IF(V[I1]=0)
else
P:=1/R[N6+I1];
IF(P>P2) then
begin
P:=0
I8:=I8+1;
R[N6+I1]:=0;
GOTO 2410
end
//IF(P>P2)
R[N6+I1]:=P;
I6:=I1-1;
FOR I2:=1 TO I6 do
begin
N7:=N5[I2];
A:=P*R[N7+I1];
FOR I3:=I2 TO N do
begin
IF(I3<I1) then
begin
N8:=N5[I3];
D:=R[N8+I1];
R[N7+I3]:=R[N7+I3]+D*A;
end;//IF(I3<I1)
if(i3>i1) then
begin
D:=-R[N6+I3];
R[N7+I3]:=R[N7+I3]+D*A;
end;//if(i3>i1)
END;// I3
END;// I2
I6:=I1+1;
FOR I2:=I6 TO N do
begin
A:=P*R[N6+I2];
N7:=N5[I2];
FOR I3:=I2 TO N do
R[N7+I3]:=R[N7+I3]-A*R[N6+I3];
END;// I2
2410: I6:=I1-1;
FOR I2:=1 TO I6 do
begin
N7:=N5[I2]+I1;
R[N7]:=-P*R[N7];
END;// I2
I6:=N6+I1+1;
I7:=N+N6;
FOR I2:=I6 TO I7 do
R[I2]:=P*R[I2];
END;// I1
M1:=N-L1-I8;
KA:=M1;
FOR J1:=1 TO L1 do
begin
N6:=N5[J1]
R2:=R[N6+J1]-1
P:=R2/V[J1]/V[J1];
S1:=P/M1;
R2:=SQRT(R2);
M2:=M-M1-1;
KB:=M2
MP:=P;
MS1:=S1;
str:='第'+inttostr(j1)+'应变量: '+'回归自由度:'+inttostr(m1);
str:=str+' 回归平方和: '+floattostrf(mp,fffixed,6,6)+' 回归均方: '+floattostrf(ms1,fffixed,6,6);
//SA4$;SA3$;M1;TAB[32];SA4$;SA2$;MP;TAB[57];SA4$;SA5$;MS1
memo1.lines.add(str);
MR:=R2
memo1.lines.add(' 复相关系数:'+floattostrf(MR,fffixed,6,6));
memo1.lines.add('');
END;// J1
M1:=M-M1-1;
//if m1<>0 then
//begin
if m1=0 then d:=0
else
D:=1/M1;
FOR I1:=1 TO L1 do
IF(V[I1]=0) then
begin
N6:=N5[I1]
I6:=N6+I1;
I7:=N6+N
FOR I2:=I6 TO I7 do
R[I2]:=0;
end//IF(V[I1]=0)
else // IF(V[I1]=0)
begin
A:=0;
P:=1/V[I1];
N6:=N5[I1];
I6:=L1+1;
FOR I2:=I6 TO N do
IF(R[I2]<>0) then
begin
R[N6+I2]:=-R[N6+I2]*V[I2]*P
A:=A+R[N6+I2]*G1[I2];
end;// IF(R[I2]<>0)
F:=2-R[N6+I1];
IF(F>0) then
begin
S2:=F/V[I1]/V[I1];
if d=0 then f:=0 //-------------------------------
else //------------------------------
F:=(1-F)/F/D/(N-L1-I8);
// GOTO 2900;
end
else
begin
S2:=0;
F:=1e+37;
// goto 2900;
end;
{2900:}V[I1]:=S2*D;
S1:=S2*D;
MS:=S2;
str:='第'+inttostr(I1)+'应变量: 剩余自由度：'+inttostr(m1);
str:=str+' 剩余平方和: '+floattostrf(ms,fffixed,6,6);//TAB[15];SA6$;SA3$;M1;TAB[32];SA6$;SA2$;MS;
MS:=S1;
MF:=F;
str:=str+' 剩余均方: '+floattostrf(ms,fffixed,6,6);
memo1.lines.add(str);
//GOSUB 4000
if KB+KA*F=0 then X:=0
else
X:=KB/(KB+KA*F);
YW:=SQRT(1-X);
YQ:=SQRT(X);
MY:=2*round(KA/2)-KA+2;
NY:=2*round(KB/2)-KB+2;
IF(MY>1) then //GOTO 4100
begin
if(NY>1) then //GOTO 4140
begin
PY:=X;
DY:=X*(1-X);
//GOTO 4190;
end//IF(MY>1)and if(NY>1)
else //if(NY>1)
begin
PY:=YQ
DY:=(1-X)*PY/2;
end;//GOTO 4190
end;// IF(MY>1)
if (my<=1) then
begin
IF(NY>1) then //GOTO 4170
begin
PY:=1-YW;
DY:=YW*X/2;
end // IF(NY>1)
else //IF(NY>1)
begin
PY:=1-0.6366197724*arctan(YW/YQ);
DY:=0.3183098862*YW*YQ;
//GOTO 4190
end;
end;//if (my<=1)
//4190:
DM:=MY;
I:=NY
while i<=kb do
begin
DI:=I;
if(kb<=i) then break;
IF(KB>I) then
begin
PY:=PY-2*DY/DI;
DY:=DY*X*(DM+DI)/DI;
END;// IF(KB<I)
i:=i+2;
end;//while
I:=MY
while i<=ka do
begin
IF(KA>I) then
begin
DM:=I
PY:=PY+2*DY/DM;
DY:=DY*(1-X)*(DM+DI)/DM
END// IF(KA>I)
else break;
i:=i+2;
end;
if (x=0) or (x=1) then dy:=0 //---------------------------
else //----------------------------
DY:=DY/X/(1-X);
IF(PY<0) THEN PY:=0;
IF(DY<0) THEN DY:=0;
//end Gosub4000.

MPY:=PY;
// LPRINT TAB[9];SA7$;MF;TAB[32];SA8$;" n1:";KA;TAB[57];SA8$;" n2:";KB:LPRINT TAB[2];SA9$;1!-MPY;
str:=' F值: '+floattostrf(mf,fffixed,6,6)+' F参数n1: '+
floattostrf(ka,fffixed,6,6)+' F参数n2: '+floattostrf(kb,fffixed,6,6);
memo1.lines.add(str);
memo1.lines.add('');
str:='可信度 1-a:'+ floattostrf(1-MPY,fffixed,6,6);
IF(PY<=0.01) THEN
str1:=' 可信度极高!!!'
else
IF(PY<=0.05) THEN
str1:=' 可信度高!!';
if (py>0.05) then
str1:='';
//2990 LPRINT A0$;TAB[53];"显著性水平 a:";MPY
memo1.lines.add(str+str1+' 显著性水平 a:'+floattostrf(mpy,fffixed,6,6));
R[N6+I1]:=G1[I1]-A;
end
//end else IF(V[I1]=0)
//end else memo1.lines.add('因为变量数等于样本数，结果为准确值');
str:='';
A:=1/M;
I6:=L1+1;
FOR I1:=I6 TO N do
IF(V[I1]<>0) then
V[I1]:=A/V[I1]/V[I1];
// I1
EPS5:=0.0000001;
EPS6:=EPS5*0.5+1;
//GOSUB 5500
MR1:=R[1];
XX[1]:=MR1;
I2:=1;
K:=N-L1+1;
FOR J:=1 TO L1 do
begin
I2:=I2+L1-J;
K1:=(J-1)*K+I2+1
K2:=J*K+I2;
FOR I:=K1 TO K2-1 do
begin
MRI:=R
IF (ABS(XX[J])<ABS(MRI)) THEN
XX[J]:=MRI;
END;// I
IF(J<>L1) then
begin
MR2:=R[K2];
XX[J+1]:=MR2;
end;
END;// J
//end gosub5500
memo1.lines.add('');
memo1.lines.add(' '+inttostr(NYANG)+'次回归方程');
memo1.lines.add('------------------------------');
MR1:=R[1];

IF (ABS(MR1/XX[1])>=EPS5) then
memo1.lines.add('Y1= '+floattostrf(MR1*EPS6,fffixed,6,6 ))
else
memo1.lines.add('Y1= 0');
memo1.lines.add('');
I2:=1
K:=N-L1+1
FOR J:=1 TO L1 do
begin
I2:=I2+L1-J;
K1:=(J-1)*K+I2+1;
K2:=J*K+I2;
IY25:=L1;
FOR I:=K1 TO K2-1 do
begin
IY25:=IY25+1
MRI:=R;
IF (ABS(MRI/XX[J])>=EPS5) then //X[]-XX[]
if MRI*EPS6>=0 then
str:='+'+floattostrf(MRI*EPS6,fffixed,6,6)
else
str:=floattostrf(MRI*EPS6,fffixed,6,6);
//LPRINT TAB[6];USING"+#.####^^^^";MRI*EPS6;
strX:=VV[IY25]
//x-strx
// GOSUB 6000
NX:=LENGTH(strX);
MX:=round(NX/3+2);
CX[0]:=0;
BB:='*';
FOR IX:=0 TO MX do
begin
// CX[IX+1]:=INSTR(CX[IX]+1,strX,BB);//old
TempStrx:=copy(strX,round(CX[IX])+1,nx-round(CX[IX]));
CX[IX+1]:=cx[ix]+Pos(BB,TempStrx);
IF (CX[IX+1]<>0) THEN
SX[IX+1]:=copy(StrX,round(CX[IX])+1,round(cx[ix+1]-cx[ix]-1))
//DX$[]-SX[]
else goto 6100
//break;
END;// IX
6100: SX[IX+1]:=copy(strX,round(CX[IX])+1,2);
strx:='';
FOR IXX:=1 TO IX do
begin
IJXX:=1;
IF SX[IXX]=''THEN continue;
FOR JXX:=IXX+1 TO IX+1 do
begin
IF SX[JXX]='' THEN continue;
IF (SX[IXX]=SX[JXX]) THEN
begin
IJXX:=IJXX+1;
SX[JXX]:='';
end;
END;// JXX
IF (IJXX>1) THEN
strX:=strX+'*'+SX[IXX]+'^'+inttoSTR(IJXX)
ELSE strX:=strX+'*'+SX[IXX]
END;// IXX
IF (SX[IX+1]<>'') THEN
strX:=strX+'*'+SX[IX+1];
//END GOSUB 6000
// LPRINT X$
memo1.lines.add(' '+str+' '+strX);
memo1.lines.add('');
end;//i
IF(J<>L1) then
begin
MR2:=R[K2];
str:='Y'+inttostr(J+1)+'=';
IF (ABS(MR2/XX[J+1])>EPS5) then
memo1.lines.add(str+floattostr(MR2*EPS6))
else memo1.lines.add(str);
end;//IF(J<>L1)
END;// J
END;// NYANG
memo1.lines.add('----------多 元 回 归 计 算 结 束----------');
savea.enabled:=true;
print.enabled:=true;
end;







procedure TForm1.PageControl1Change(Sender: TObject);
var i:integer;
begin
if pageControl1.ActivePage=TabSheet2 then
begin
sedit3.Value:=1;
sedit3.enabled:=false;
label7.enabled:=false;
stringgrid1.Cells[1,0]:='Y';
for i:= 1 to Sedit2.value-1 do
stringgrid1.Cells[i+1,0]:='X'+inttostr(i);
end else begin
sedit3.enabled:=true;
label7.enabled:=true;end;

end;


//***** 多 元 线 性 回 归 程 序 ***** *************************
// 1. 主 要 功 能 :
// 此程序根据已知的自变量 X1 , X2 , ..., XP 和因变量 Y 的 N 组原
// 始观测值 ,用最小二乘法计算回归系数的估值 ,建立回归方程 .
// 对回归方程进行方差分析和显著性检验 .
// 对回归系数的估值进行统计检验 .
//
// 2. 主 要 标 识 符 说 明 :
// N -- 样品数 .
// P -- 自变量数 .
// NN -- 待予报样品数 .
// X[N,P] -- 自变量 X1 , X2 , ... , XP 的原始数据 .
// XN[NN,P] -- 待予报样品的自变量数据.
// Y[N] -- 因变量 Y 的原始数据 .
// XMEAN[P]-- 自变量的均值 .
// YMEAN -- 因变量 Y 的均值 .
// L[P,P] -- 正规方程的系数矩阵 .
// LY[P] -- 正规方程的右端常数项 .
// C[P,P] -- 正归方程系数矩阵的逆矩阵 .
// B0 -- 回归方程的常数项 .
// B[P] -- 回归方程的系数 .
// LYY -- 离差平方和 .
// U -- 回归平方和 .
// Q -- 残差[ 剩余 ]平方和 .
// F -- 回归方程显著性检验量[ 回归方差与剩余方差之比 ] .
// R -- 复相关系数 .
// SY -- 剩余标准差 .
// TI[P] -- 回归系数 t 检验值 .
// FI[P] -- 回归系数 F 检验值 .
// VI[P] -- 自变量偏回归平方和 .
// RI[P] -- 自变量偏相关系数 .
// S[P,P+1] -- 用于解正归方程的工作存储单元 .
procedure TForm1.BitBtn3Click(Sender: TObject);
var
str:string;
i,j,k,p,n,nn:integer;
D,A,B0,Q,F,R,SY,U,LYY,Ymean,Y1:single;
X:array[1..100,1..20] of single;
Xn:array[1..50,1..20] of single;//待 预 测 样 品
Y:array[1..100] of single;
L,S,C:array[1..20,1..20]of single;
B,Xmean,Ly,Ti,Fi,Vi,Ri:array[1..20] of single;

begin
n:=Sedit1.value
// NO.
p:=Sedit2.value-1
//X+Y
for i:= 2 to p+1 do
for j:= 1 to n do
if StringGrid1.cells[i,j]='' then
begin
showmessage('第'+inttoStr(j)+'行,第'+inttoStr(i)+'列数据为空!');
exit;
end
else try
X[j,i-1]:=Strtofloat(StringGrid1.cells[i,j]);//读 入 自 变 量 X1, X2, ... ,XP
Y[j]:=Strtofloat(StringGrid1.cells[1,j]);//读 入 因 变 量 Y 的 原 始 数 据
except
showmessage('原始数据中第'+inttoStr(j)+'行,第'+inttoStr(i)+'列数据非法!');
exit;
end;
if checkbox3.Checked=true then //待预测样品
begin
nn:=Spinedit1.Value;
for i:=1 to p do
for j:= 1 to nn do
try
Xn[j,i]:=Strtofloat(StringGrid2.cells[i,j]);//读入
except
showmessage('预测样品数据中第'+inttoStr(j)+'行,第'+inttoStr(i)+'列数据非法!');
exit;
end;
end else nn:=0;
//以上if..else..end共25行判断数据是否有误!public

memo1.lines.clear;//清理输出筐

memo1.lines.add(' ********************************');
memo1.lines.add(' * 线 性 回 归 计 算 结 果 *');
memo1.lines.add(' ********************************');
memo1.lines.add('(1)基 本 参 数');
memo1.lines.add('---------------');
memo1.lines.add('样 品 数: '+inttoStr(n));
memo1.lines.add('自 变 量 数: '+inttoStr(p));
if checkbox3.Checked=true then
memo1.lines.add('待预测样品数: '+inttoStr(nn));
memo1.lines.add('');
savea.Enabled:=true
//
print.Enabled:=true;// make the button can use
if checkbox2.Checked=true then//输出原始数据;
begin
memo1.lines.add('* 原始数据');
memo1.lines.add('------------');
str:='Y ';
for i:= 1 to p do
str:=str+' X['+inttoStr(i)+'] ';
memo1.lines.add(str);
for i:= 1 to n do begin
str:=floatToStrF(Y,ffGeneral,3,1)+' ';
for j:= 1 to p do
str:=str+floattostrF(X[i,j],ffGeneral,3,1)+' ';
memo1.lines.add(str);
str:='';
end;//i
end;//if

// 计 算 自 变 量 与 因 变 量 的 均 值 . *
FOR J:=1 TO P do begin
D:=0;
FOR I:=1 TO N do
D:=D+X[I,J];
XMEAN[J]:=D/N;
end;// J
D:=0;
FOR I:=1 TO N do
D:=D+Y;
YMEAN:=D/N;

memo1.lines.add('');
memo1.lines.add('X1 到 X'+inttoStr(P)+' 的 均 值');
memo1.lines.add('-------------------');
FOR J:=1 TO P do
memo1.lines.add(floattostrf(XMEAN[J],ffGeneral,5,2));
memo1.lines.add('');
memo1.lines.add('Y 的 均 值 : '+floattostrf(YMEAN,ffGeneral,5,2));

// 计 算 正 规 方 程 的 系 数 矩 阵 L[ ] 和 右 端 常 数 项 . *
FOR I:=1 TO P do begin
FOR J:=1 TO P do begin
D:=0;
FOR K:=1 TO N do
D:=D+(X[K,I]-XMEAN)*(X[K,J]-XMEAN[J]);
L[I,J]:=D;
L[J,I]:=L[I,J];
end;// J
end;// I
FOR I:=1 TO P do begin
D:=0;
FOR K:=1 TO N do
D:=D+(X[K,I]-XMEAN)*(Y[K]-YMEAN);
LY:=D;
end;// I
// 打 印 正 规 方 程 的 系 数 矩 阵 L[ ] 和 右 端 常 数 项 . *
memo1.lines.add('');
memo1.lines.add('正 规 方 程 的 系 数 矩 阵 ,L[ ]');
memo1.lines.add('-----------------------------------');
FOR I:=1 TO P do begin
str:='';
FOR J:=1 TO P do
str:=str+floattostrF(L[I,J],ffGeneral,5,2)+' ';
memo1.lines.add(str);
end;// I
memo1.lines.add('');
memo1.lines.add('正 规 方 程 的 右 端 常 数 项, LY[ ] :');
memo1.lines.add('--------------------------------------');
FOR I:=1 TO P do
memo1.lines.add(floattostrf(LY,ffGeneral,5,2));

// 计 算 矩 阵 L[ ] 的 逆 矩 阵 . *
FOR I:=1 TO P do begin
FOR J:=1 TO P do
S[I,J]:=L[I,J];
S[I,P+1]:=LY;
end;// I
//**
FOR K:=1 TO P do begin//计算逆矩阵和解线性方程组子程序
A:=1/S[K,K];
FOR I:=1 TO P do
FOR J:=1 TO P+1 do
IF (I<>K) AND (J<>K) THEN S[I,J]:=S[I,J]-S[I,K]*S[K,J]*A;
FOR J:=1 TO P+1 do begin
S[K,J]:=S[K,J]*A;
IF J<>P+1 THEN S[J,K]:=-S[J,K]*A;
end;// J
S[K,K]:=A;
end;// K
FOR I:=1 TO P do
FOR J:=1 TO P do
C[I,J]:=S[I,J];
FOR I:=1 TO P do
B:=S[I,P+1];
//**过程结束

//输 出 矩 阵 L[ ] 的 逆 矩 阵 .
memo1.lines.add('');
memo1.lines.add('正规方程系数矩阵L[ ]的逆矩阵,C[ ]:');
memo1.lines.add('-------------------------------------');
FOR I:=1 TO P do begin
str:='';
FOR J:=1 TO P do
Str:=str+ floattostrF(C[I,J],ffGeneral,5,2)+' ';
memo1.lines.add(str);
end;// I

//**********************************************************************
// 计 算 和 打 印 回 归 系 数 与 回 归 方 程 . *
// **********************************************************************
B0:=YMEAN;
FOR J:=1 TO P do
B0:=B0-B[J]*XMEAN[J];
memo1.lines.add('');
memo1.lines.add('回 归 系 数');
memo1.lines.add('-----------');
memo1.lines.add('B0 ='+floattoStrf(B0,ffGeneral,5,2));
FOR J:=1 TO P do
memo1.lines.add('B'+inttoStr(J)+'='+floattostrf(B[j],ffGeneral,5,2));
memo1.lines.add('');
memo1.lines.add(' 回 归 方 程 : ');
str:='';
Str:='Y ='+floattoStrf(B0,ffGeneral,4,1);
FOR J:=1 TO P do begin
IF B[J]>0 THEN Str:=str+'+';
str:=Str+floatTostrf(B[J],ffGeneral,4,1)+'*X'+inttoStr(j);
end;// J
memo1.lines.add(str);

//计 算 和 打 印 方 差 分 析 表
memo1.lines.add('');
if p+1=n then begin
memo1.lines.add('准 确 值 无 方 差 分 析...程序结束！！！！');exit
end;
U:=0;
LYY:=0;
FOR J:=1 TO P do
U:=U+B[J]*LY[J];
FOR J:=1 TO N do
LYY:=LYY+sqr(Y[J]-YMEAN);
Q:=LYY-U;
if Q=0 then
memo1.lines.add('残差平方和为 0 !......取消方差分析及回归方程显著性检验。')else
begin
F:=U*(N-P-1)/(P*Q);
SY:=Q/(N-P-1);
memo1.lines.add(' 方 差 分 析 表 : ');// 打 印 方 差 分 析 表 .
memo1.lines.add('---------------------');
memo1.lines.add(' 平 方 和 自 由 度 方 差 F 检 验 值');
memo1.lines.add('');
memo1.lines.add('回归平方和 U ='+floattostrF(U,ffGeneral,5,2)+' P = '+floattostrf(P,ffGeneral,5,2)+' U/P = '+floatToStrf(U/P,ffGeneral,4,1));
memo1.lines.add('');
memo1.lines.add('残差平方和 Q ='+floattostrF(Q,ffGeneral,5,2)+' N-P-1='+floattostr(N-P-1)+
' Q/[N-P-1]='+floattoStrf(SY,ffGeneral,5,2)+' F='+ floattoStrf(F,ffGeneral,5,2));
memo1.lines.add('');
memo1.lines.add('离差平方和 LYY='+floattoStrF(LYY,ffGeneral,5,2)+' N-1='+floattoStr(N-1));

// 计 算 和 打 印 回 归 方 程 显 著 性 检 验 量 .
R:=SQRT(1-Q/LYY);
SY:=SQRT(SY);
memo1.lines.add('');
memo1.lines.add('复 相 关 系 数 , R = '+floatToStr(R));
memo1.lines.add('剩 余 标 准 差 , SY ='+floatToStr(SY));
memo1.lines.add('回归方差与剩余方差之比F='+floatToStr(F));

// 计 算 统 计 检 验 量
FOR J:=1 TO P do begin
TI[J]:=B[J]/(SQRT(C[J,J])*SY);
VI[J]:=B[J]*B[J]/C[J,J];
RI[J]:=B[J]/SQRT(C[J,J]*Q+B[J]*B[J]);
FI[J]:=TI[J]*TI[J];
end;// J
memo1.lines.add('');
memo1.lines.add('各 个 自 变 量 的 t 检 验 值 TI[1] TO TI['+intToStr(P)+']');
memo1.lines.add('-------------------------------------------');
FOR J:=1 TO P do
memo1.lines.add(floatToStr(TI[J]));
memo1.lines.add('t 检 验 的 自 由 度 , N-P-1 = '+floatToStr(N-P-1));
memo1.lines.add('');
memo1.lines.add('各个自变量的 F 检验值, FI[1 ] TO FI['+intToStr(P)+']');
memo1.lines.add('--------------------------------------');
FOR J:=1 TO P do
memo1.lines.add(floatToStr(FI[J]));
memo1.lines.add('');
memo1.lines.add('F 检 验 的 自 由 度 : ');
memo1.lines.add('自 由 度 1 = 1 , 自 由 度 2 ='+inttoStr(N-P-1));
memo1.lines.add('');
memo1.lines.add('各个自变量的回归平方和, VI[1] TO VI['+intToStr(P)+']');
memo1.lines.add('--------------------------------------');
FOR J:=1 TO P do
memo1.lines.add(floatToStr(VI[J]));
memo1.lines.add('');
memo1.lines.add('各个自变量的偏相关系数, RI[1] TO RI['+intToStr(P)+']');
memo1.lines.add('---------------------------------------');
FOR J:=1 TO P do
memo1.lines.add(floatToStr(RI[J]));
memo1.lines.add('');
end;//if Q=0

// 计 算 和 打 印 待 予 报 样 品 的 予 报 值 .
IF NN>0 THEN begin
memo1.lines.add('待预测样品的自变量数据与预测 Y 值(最后一列)');
memo1.lines.add('------------------------------------------');
FOR I:=1 TO NN do begin
Y1:=B0;
str:='预测样品('+inttoStr(I)+') ';
FOR J:=1 TO P do begin
str:=str+floatToStr(XN[I,J])+' ';
Y1:=Y1+B[J]*XN[I,J];
end;// J
str:=str+'--->'+floatToStr(Y1);
memo1.lines.add(Str);
end;// I
end;//if
memo1.lines.add('');
memo1.lines.add('***** 计 算 结 束 *****');


end;



procedure TForm1.SpinEdit1Change(Sender: TObject);
var i:integer;
begin
try
StringGrid2.rowCount:=SpinEdit1.value+1;
for i:= 1 to SpinEdit1.value+1 do
StringGrid2.cells[0,i]:='预测数'+inttoStr(i);
except showmessage('预测数据个数不能为空!');
end;//try
end;

procedure TForm1.CheckBox3Click(Sender: TObject);
begin
panel1.visible:=Checkbox3.Checked;
end;

{*********************************************************
***** 逐 步 回 归 分 析 *****
* 1. 主 要 功 能 :
* 此程序根据已知的自变量 X1 , X2 , ..., Xp 和因变量 Y 的 N 组原
* 始观测值 ,通过对各个自变量方差贡献的显著性检验 ,逐一选入或剔除用
* 以建立回归方程的某些自变量 ,建立回归方程 ,使最终的回归方程只保留
* 重要变量 .
* 计算出残差平方和 ,复相关系数 ,偏相关系数 ,剩余标准差等统计量,
* 用以分析检验回归效果 .
*
* 2. 主 要 标 识 符 说 明 :
* N -- 样品数 .
* P -- 自变量数+1 .
* F1 -- 用以引入自变量的临界值 .
* F2 -- 用以剔除自变量的临界值 .
* NN -- 待予报样品数 .
* EPS -- 防止矩阵退化的容差 .
* XY(N,P+1) -- 自变量 X1 ,X2 ,...,Xp 和因变量 Y 的原始数据 .
* XN(NN,P) -- 待予报样品的自变量数据 .
* MEAN(P+1)-- 各变量的均值 .
* R(P+1,P+1) -- 先用于存放离差矩阵 ,后存放相关矩阵 .
* H(P+1) -- 离差矩阵对角线上元素的平方根 .
* STEPN -- 计算步数 .
* L -- 已引入回归方程的自变量个数 .
* QFD -- 残差平方和的自由度 .
* VMIN -- 已引入的各自变量贡献的最小值 .
* VMAX -- 未引入的各自变量贡献的最大值 .
* IMIN -- 贡献最小的已引入自变量的序号 .
* IMAX -- 贡献最大的未引入自变量的序号 .
* V -- 自变量的贡献 .
* FK1 -- 待引入自变量的 F 检验值 .
* FK2 -- 待剔除自变量的 F 检验值 .
* K -- 被剔除或引入的自变量序号 .
* B0 -- 回归方程的常数项 .
* B(P) -- 回归方程的系数 .
* Q -- 残差平方和 .
* S -- 剩余标准差 .
* RR -- 复相关系数 .
* F -- 回归方差与剩余方差之比 .
* TI(P) -- 回归系数 t 检验值 .
* RI(P) -- 各自变量的偏相关系数 .
* E(N) -- 残 差 (各个原始样品观测 Y 值与回归计算 Y 值之差) .
*
* 3. 参 数 提 供 方 法 :
* 程序运行时 ,请从屏幕上打入下列参数 :
* 样品数 : N ,自变量数 : P , 临界值 F1 , F2 ,待予报样品数 : NN
* , 打印指示参数 P$ .
*
* 4. 原 始 数 据 的 排 列 :
* 原始数据放在源程序末尾的 DATA 语句中,其顺序是:
* X11, X12, ... , X1P, Y1
* X21, X22, ... , X2P, Y2
* .......................
* XN1, XN2, ... , XNP, YN
* 即按样品顺序排列.
* 如果有待予报样品 , 其自变量数据紧接在后 , 仍按样品排列 .
*
* 5. 子 程 序 :
进行矩阵变换 . *
*
* 6. 主 要 计 算 结 果 :
* 回归方程 .
* 回归方差与剩余方差之比 F ,复相关系数 RR ,剩余标准差 S .
* 统计检验量 :各个回归系数的 t 检验值 TI( ) , 各个自变量的偏相
* 关系数 RI( ) .
*
* 7. 说 明 :
* (1) 应有 F1 >= F2 ( 一般常令 F1 = F2 ), 如果令 F1=F2=0, 则此
* 程序相当于进行一般多元线性回归 .
* (2) 如果某变量为常数 , 则无法计算相关系数 ,程序运行将中断 ,此
* 时应重新准备原始数据 .
* (3) 如果要进行非线性回归 ,则用户需自行在程序中原始数据读入之后
加进必要的数据变换语句 .
* (4) 为保证计算顺利 ,计算中如遇 R(i,i) < EPS , 则 Xi 不考虑引进,
* EPS 一般取 0.001 到 0.0001 之间 . 本程序令 EPS = 0.0000001 .
* (5) 用户使用的打印机应当能打印 132 列 . }

procedure TForm1.BitBtn4Click(Sender: TObject);
label 3250;
const EPS=0.0000001;
type myarray=array[1..20,1..20]of single;
var str:string;
i,j,k,p,n,nn,StepN,L,QFD,IMIN,IMAX:integer;
A,B0,Q,F1,F2,SY,V,LYY,Fk2,VMIN,VMAX,FK1,RR,S,F,Y:single;
XY:array[1..100,1..20] of single;
E:array[1..100]of single
Xn:array[1..50,1..20] of single;//待 预 测 样 品
//Y:array[1..100] of single;
R,C:myarray;
B,mean,H,Ti,Fi,Vi,Ri:array[1..20] of single;
// 进 行 矩 阵 变 换 .
procedure cov(Var R:myArray;p,k:integer);
var A:single;
i,j:integer;
begin
A:=1/R[K,K];
FOR I:=1 TO P do
FOR J:=1 TO P do
IF (I<>K) AND (J<>K)
THEN R[I,J]:=R[I,J]-(R[I,K]*R[K,J]*A);
FOR J:=1 TO P do begin
R[K,J]:=R[K,J]*A;
R[J,K]:=-R[J,K]*A;
end;// J
R[K,K]:=A;
if Mcheckbox.checked then begin
memo1.lines.add('');
memo1.lines.add('变 换 后 的 矩 阵 R[ ]:');
FOR I:=1 TO P do begin
FOR J:=1 TO P do
Str:=Str+floatToStrF(R[I,J],fffixed,5,5)+' , ';
memo1.lines.add(str);
str:='';
end;
end;//if Mcheckbox.checked then begin
end;//end procedure

begin
n:=Sedit1.value
// NO.
p:=Sedit2.value
//X+Y
try
f1:=StrtoFloat(edit2.text);
f2:=StrtoFloat(edit3.text);
except showmessage('F1 或 F2 数据非法!');
end;
for i:= 1 to p-1 do
for j:= 1 to n do
if StringGrid1.cells[i,j]='' then
begin
showmessage('第'+inttoStr(j)+'行,第'+inttoStr(i)+'列数据为空!');
exit;
end
else try
XY[j,i]:=Strtofloat(StringGrid1.cells[i+1,j]);//读 入 自 变 量 X1, X2, ... ,XP
XY[j,p]:=Strtofloat(StringGrid1.cells[1,j]);//读 入 因 变 量 Y 的 原 始 数 据
except
showmessage('原始数据中第'+inttoStr(j)+'行,第'+inttoStr(i)+'列数据非法!');
exit;
end;
if checkbox4.Checked=true then //待预测样品
begin
nn:=Spinedit2.Value;
for i:=1 to p-1 do
for j:= 1 to nn do
try
Xn[j,i]:=Strtofloat(StringGrid3.cells[i,j]);//读入
except
showmessage('预测样品数据中第'+inttoStr(j)+'行,第'+inttoStr(i)+'列数据非法!');
exit;
end;
end else nn:=0;
//以上if..else..end共25行判断数据是否有误!public

memo1.lines.clear;//清理输出筐

memo1.lines.add(' ********************************');
memo1.lines.add(' * 逐 步 回 归 计 算 结 果 *');
memo1.lines.add(' ********************************');
memo1.lines.add('(1)基 本 参 数');
memo1.lines.add('---------------');
memo1.lines.add('样 品 数: '+inttoStr(n));
memo1.lines.add('自 变 量 数: '+inttoStr(p));
memo1.lines.add('用以引入自变量的临界值，F1'+floattostr(f1));
memo1.lines.add('用以剔除自变量的临界值，F2'+floattostr(f2));
if checkbox3.Checked=true then
memo1.lines.add('待预测样品数: '+inttoStr(nn));
memo1.lines.add('');

savea.Enabled:=true
//
print.Enabled:=true;// make the button can use

if checkbox5.Checked=true then//输出原始数据;
begin
memo1.lines.add('原始数据');
memo1.lines.add('------------');
str:='Y ';
for i:= 1 to p do
str:=str+' X['+inttoStr(i)+'] ';
memo1.lines.add(str);
for i:= 1 to n do begin
//str:=floatToStrF(XY[i,1],ffGeneral,3,1)+' ';
for j:= 1 to p do
str:=str+floattostrF(XY[i,j],ffGeneral,3,1)+' ';
memo1.lines.add(str);
str:='';
end;//i
end;//if

// 计 算 自 变 量 与 因 变 量 的 均 值 .
FOR j:=1 TO P do begin
MEAN[J]:=0;
FOR I:=1 TO N do
MEAN[J]:=MEAN[J]+XY[I,J];
MEAN[J]:=MEAN[J]/N;
end;// J
// 打 印 均 值 .
memo1.Lines.add('');
memo1.lines.add('X1 到 X'+inttoStr(P-1)+' 的和 Y 的 均 值 均 值');
memo1.lines.add('--------------------------------------');
FOR J:=1 TO P-1 do
memo1.lines.add('X_'+inttoStr(j)+' : '+floattostr(MEAN[J]));
memo1.lines.add('- - - - - - -');
memo1.lines.add('Y : '+floattostr(MEAN[P]));

memo1.lines.add('');
//计 算 离 差 矩 阵 和 它 的 对 角 线 上 元 素 的 平 方 根 .
FOR I:=1 TO P do begin
FOR J:=1 TO I do begin
R[I,J]:=0;
FOR K:=1 TO N do begin
R[I,J]:=R[I,J]+(XY[K,I]-MEAN)*(XY[K,J]-MEAN[J]);
R[J,I]:=R[I,J];
end;// K
end;// J
H:=SQRT(R[I,I]);
end;// I
if Mcheckbox.checked then begin
memo1.lines.add('离 差 矩 阵 R[ , ]');
memo1.lines.add('-------------------');
FOR I:=1 TO P do begin
FOR J:=1 TO P do
STR:=Str+floatToSTRF(R[I,J],ffGeneral,6,1)+' , ';
memo1.lines.add(str);
str:='';
end;// I
memo1.lines.add('');
memo1.lines.add('离差矩阵对角线上元素的平方根, H[ ]:');
memo1.lines.add('-----------------------------------');
FOR J:=1 TO P do
memo1.lines.add(floatToSTR(H[J])+' ');
end;
// 计 算 打 印 相 关 系 数 矩 阵 .
FOR I:=1 TO P do
FOR J:=1 TO I do begin
R[I,J]:=R[I,J]/(H*H[J]);
R[J,I]:=R[I,J];
end;// J
memo1.lines.add('');
memo1.lines.add('相 关 系 数 矩 阵, R[ , ]:')
// :" :L
memo1.lines.add('--------------------------');
FOR I:=1 TO P do begin
FOR J:=1 TO P do
STR:=Str+floatToSTRF(R[I,J],fffixed,5,5)+' , ';
memo1.lines.add(str);
str:='';
end;// I
memo1.lines.add('');
STEPN:=0
L:=0
QFD:=N-1;
//重 新 开 始 新 的 一 步 计 算 .
while stepn<30 do
begin
STEPN:=STEPN+1
//memo1.lines.add('NOW ,STEP ='+inttoStr(STEPN));
VMIN:=10000
VMAX:=0 IMIN:=1
IMAX:=1
memo1.lines.add('');
memo1.lines.add(' 第 '+inttoStr(STEPN)+' 步 计 算 结 果 ');
if Mcheckbox.checked then
memo1.lines.add('自 变 量 X[ 1 ] 到 X['+inttoStr(P)+'] 的 贡 献 :');
FOR I:=1 TO P-1 do begin //2720
IF R[I,I]<EPS THEN continue;
V:=R[I,P]*R[P,I]/R[I,I];
if Mcheckbox.checked then begin
memo1.lines.add('V['+inttoStr(I)+']='+floatToStr(ABS(V)));
IF V<0 THEN memo1.lines.add('(已 引 入)')ELSE memo1.lines.add('(未 引 入)');
end;
IF V>=0 THEN
IF V>VMAX THEN begin VMAX:=V;IMAX:=I;
continue
end;
IF ABS(V)<VMIN THEN VMIN:=ABS(V) IMIN:=I;
end;// I
if Mcheckbox.checked then begin
memo1.lines.add('');
memo1.lines.add('未引入变量的贡献的最大值, VMAX '+floatToStr(VMAX));
memo1.lines.add('其 变 量 序 号, IMAX :='+intToStr(IMAX));
IF STEPN=1
THEN memo1.lines.add('第 一 步 : 此时还无引入变量')
else begin
memo1.lines.add('已引入变量的贡献的最小值, VMIN ='+floatToStr(VMIN));
memo1.lines.add('其 变 量 序 号, IMIN ='+intToStr(IMIN));
end;
end;
////剔 除 自 变 量 段 .
IF (STEPN=1) OR (STEPN=2) OR (STEPN=3) THEN //do nothing
else begin // 剔 除 自 变 量 计 算 .
FK2:=(N-L-1)*VMIN/R[P,P];
if Mcheckbox.checked then begin
memo1.lines.add('');
memo1.lines.add('变 量 X'+intToStr(IMIN)+'的 F 值(用 于 剔 除), FK2 ='+FloatToStr(FK2));
end;
IF FK2<F2 THEN begin
L:=L-1;
QFD:=QFD+1;
K:=IMIN
memo1.lines.add('');
memo1.lines.add('x'+inttoStr(K)+' 被 剔 除 ,方 程 中 现 有 变 量 数 L='+inttoStr(L));
cov(R,P,k);
continue;
end

end;
// 选 入 自 变 量 段 .
if R[P,P]-VMAX=0 then begin
messagebox(0,'请改用多元线性回归计算！！！','计算中断',MB_OK);
memo1.lines.add('计算中断！！！ ');
exit;
end;
FK1:=(N-L-2)*VMAX/(R[P,P]-VMAX);

if Mcheckbox.checked then begin
memo1.lines.add('');
memo1.lines.add('变 量 X'+inttoStr(IMAX)+'的 F 值(用 于 引 入),FK1 ='+floattoStr(FK1));
end;
IF FK1<F1 THEN goto 3250
L:=L+1
QFD:=QFD-1;
K:=IMAX;
memo1.lines.add('');
memo1.lines.add('x'+inttoStr(K)+'被引入, 方程中现有变量数, L='+inttoStr(L));
cov(R,P,k);
IF L=P THEN break;
end;//do

memo1.lines.add('');
memo1.lines.add('现 在 ,所 有 的 变 量 都 已 被 引 入 !!! ');
3250: IF L=0 THEN
begin
memo1.lines.add('');
memo1.lines.add('在当前的临界值F1, F2下,不能选入重要变量!');
exit;//out
end;
memo1.lines.add('');
memo1.lines.add('现在, 既不能剔除也不能选入重要变量 ');
memo1.lines.add('');
memo1.lines.add('');
memo1.lines.add(' 最 后 计 算 结 果 :');
memo1.lines.add('----------------------');
//计 算 回 归 系 数 .
FOR I:=1 TO P-1 do
IF R[I,P]*R[P,I]<0
THEN B:=R[I,P]*H[P]/H
ELSE B:=0;
B0:=MEAN[P];
FOR J:=1 TO P-1 do
B0:=B0-B[J]*MEAN[J];

//打 印 回 归 系 数 和 回 归 方 程 .

memo1.lines.add('回 归 系 数:');

memo1.lines.add('B0:='+floatToStr(B0));;
FOR J:=1 TO P-1 do
memo1.lines.add('B'+inttoStr(J)+'='+floatTostr(B[J]));

memo1.lines.add('');
memo1.lines.add('回 归 方 程 : ');
str:='Y ='+floatToStrf(B0,fffixed,6,6);
FOR J:=1 TO P-1 do begin
IF B[J]=0 THEN Continue;
IF B[J]>0 THEN str:=str+'+';
str:=str+floattoStrf(B[J],fffixed,6,6)+'*X'+inttoStr(J);
end;// J
memo1.lines.add(Str);

//计 算 和 打 印 各 种 显 著 性 检 验 量 .
Q:=H[P]*H[P]*R[P,P];
S:=H[P]*SQRT(R[P,P]/QFD);
RR:=SQRT(1-R[P,P]);
F:=QFD*(1-R[P,P])/(L*R[P,P]);
memo1.lines.add('');
memo1.lines.add('残 差 平 方 和 , Q ='+floatToStr(Q));
memo1.lines.add('剩 余 标 准 差 , S ='+floatToStr(S));
memo1.lines.add('复 相 关 系 数 , RR ='+floatToStr(RR));
memo1.lines.add('回归方差与剩余方差之比, F='+floatToStr(F));
FOR I:=1 TO P do begin
TI:=R[I,P]/SQRT(R[I,I]*R[P,P]/QFD);
RI:=R[I,P]/SQRT(R[I,I]*R[P,P]+R[I,P]*R[I,P]);
end;// I
memo1.lines.add('');
memo1.lines.add('各 个 自 变 量 的 t 检 验 值 , TI[1] TO TI['+inttoStr(P-1)+']:');
memo1.lines.add('---------------------------------------------');
FOR J:=1 TO P-1 do
memo1.lines.add(floatToStr(TI[J]));
memo1.lines.add('');
memo1.lines.add('各个自变量的偏相关系数, RI[1] TO RI['+inttoStr(P-1)+']:');
memo1.lines.add('----------------------------------------');
FOR J:=1 TO P-1 do
memo1.lines.add(floatToStr(RI[J]));
//计 算 和 打 印 观 测 Y 值 与 回 归 计 算 Y 值 之 差
if Mcheckbox.checked then begin
memo1.lines.add('');
memo1.lines.add('样品号 原始Y值 回归值YY Y减YY之差 相对误差百分数');
memo1.lines.add('');
FOR I:=1 TO N do begin
Y:=B0;
FOR J:=1 TO P-1 do begin
Y:=Y+B[J]*XY[I,J];
E:=XY[I,P]-Y
if i<10
then Str:='No.'+intToStr(I)+' '
else Str:='No.'+intToStr(I)+' ';
Str:=Str+FloatToStr(XY[I,P])+' ';
Str:=Str+FloatToStrF(Y,ffGeneral,6,1)+' ';
Str:=Str+FloatToStrF(E,ffGeneral,6,1)+' ';
Str:=Str+FloatToStrF(E/XY[1,P]*100,ffGeneral,6,1);
end;
memo1.lines.add(str);
str:=''
end;// I
end;//if Mcheckbox.checked then begin

// 计 算 和 打 印 待 予 报 样 品 的 予 报 值 .
IF NN>0 THEN begin
memo1.lines.add('');
memo1.lines.add('待予报样品的自变量数据与予 Y 值(最 后一列)');
memo1.lines.add('------------------------------------------');
FOR I:=1 TO NN do begin
Y:=B0;
str:='预测样品('+inttoStr(I)+') ';
FOR J:=1 TO P-1 do begin
str:=str+floatToStr(XN[I,J])+' ';
Y:=Y+B[J]*XN[I,J];
end;// J
str:=str+'--->'+floatToStr(Y);
memo1.lines.add(Str);
end;// I
end;//if nn>0
memo1.lines.add('');
memo1.lines.add(' 逐 步 回 归 分 析 计 算 结 束!!! ');

end;// 结束逐步回归分析！



procedure TForm1.CheckBox4Click(Sender: TObject);
begin
panel2.visible:=Checkbox4.Checked;
end;

procedure TForm1.SpinEdit2Change(Sender: TObject);
var i:integer;
begin
try
StringGrid3.rowCount:=SpinEdit2.value+1;
for i:= 1 to SpinEdit2.value+1 do
StringGrid3.cells[0,i]:='预测数'+inttoStr(i);
except showmessage('预测数据个数不能为空!');
end;//try
end;

procedure TForm1.FormActivate(Sender: TObject);
var i,j:integer;
begin
sz:=0;
enter1.checked:=true;
coll:=sedit2.Value;
roww:=sedit1.value;
stringgrid1.cells[0,0]:='数据/变量';
for i:=1 to sedit3.value do
stringgrid1.Cells[i,0]:='Y_'+inttostr(i);
for i:=1 to (sedit2.value-sedit3.value) do
stringgrid1.Cells[i+sedit3.value,0]:='X_'+inttostr(i);
for j:=1 to sedit1.value do
stringgrid1.cells[0,j]:='数据'+inttostr(j);
end;

procedure TForm1.saveaClick(Sender: TObject);
var savefile:textfile;line:integer;
begin
Savedialog1.FilterIndex:=2;
if Savedialog1.execute then
begin
AssignFile(savefile,savedialog1.filename);
rewrite(savefile);
for Line := 0 to Memo1.Lines.Count - 1 do
Writeln(savefile, Memo1.Lines[Line]);
if checkbox6.checked then
begin
writeln(savefile,'');
writeln(savefile,'备注');
for Line := 0 to Memo2.Lines.Count - 1 do
Writeln(savefile, Memo2.Lines[Line]);
end;
closefile(savefile);
savea.enabled:=false;
end
else senda:=false

end;

procedure TForm1.N1Click(Sender: TObject);
begin
form1.WindowState:=wsMaximized;
memo1.Align:=alclient;
N1.Checked:=true;
end;

procedure TForm1.N2Click(Sender: TObject);
begin
form1.WindowState:=wsnormal;
form1.Width:=773;
form1.height:=530;
memo1.Align:=alnone;
memo1.width:=395;
memo1.Height:=297;
memo1.top:=168;
memo1.Left:=368;
N2.Checked:=true;
end;

procedure TForm1.N4Click(Sender: TObject);
begin
if fontdialog1.execute then
memo1.Font:= fontdialog1.font;
end;

procedure TForm1.N5Click(Sender: TObject);
begin
if colordialog1.Execute then
memo1.Color:=colordialog1.Color;
end;


procedure TForm1.Memo1DblClick(Sender: TObject);
begin
if memo1.align=alnone then
form1.N1click(sender)
else form1.n2click(sender)

end;

procedure TForm1.printClick(Sender: TObject);
var
Line: Integer;
PrintText: TextFile
{declares a file variable}
begin
if PrintDialog1.Execute then
begin
AssignPrn(PrintText)
{assigns PrintText to the printer}
Rewrite(PrintText)
{creates and opens the output file}
Printer.Canvas.Font := Memo1.Font
{assigns Font settings to the canvas}
for Line := 0 to Memo1.Lines.Count - 1 do
Writeln(PrintText, Memo1.Lines[Line]); {writes the contents of the Memo1 to the printer object}
if checkbox6.checked then
begin
for Line := 0 to Memo2.Lines.Count - 1 do
Writeln(PrintText, Memo2.Lines[Line]);
end;
CloseFile(PrintText)
{Closes the printer variable}
end;

end;


procedure TForm1.deleteClick(Sender: TObject);
var i,j:integer;
begin
case
messagedlg('确定要清除数据?',mtconfirmation,[mbok,mbcancel],0)
of id_ok: begin
for i:=1 to sedit3.value do
stringgrid1.cells[i,1]:='Y_'+inttostr(i);
for i:=sedit3.value+1 to sedit2.value do
stringgrid1.cells[i,1]:='X_'+inttostr(i-Sedit3.value)

for j:=1 to sedit1.value do
stringgrid1.cells[1,j]:='数据'+inttostr(j);
for i:= 1 to sedit2.value do
for j:= 1 to sedit1.value do
StringGrid1.cells[i,j]:='';
delete.Enabled:=false;
saveb.enabled:=false;
d1.Enabled:=false;
s1.Enabled:=false;
memo2.lines.clear;
sz:=0;
end

id_Cancel:;
end;
end;

procedure TForm1.FormCloseQuery(Sender: TObject
var CanClose: Boolean);
begin
if form1.WindowState=wsMaximized then
begin
canclose:=false;
Form1.N2Click(Sender);
exit;
end;
if form1.windowstate=wsNormal then
begin
if savea.enabled then
begin
case
messagedlg('运行所得结果未保存，是否保存？',mtconfirmation,mbyesnocancel,0)
of id_yes:begin
Form1.saveaClick(Sender);
if not senda then
canclose:=false;end;
id_no:;
id_cancel:canclose:=false;
end;
end;
end;
if saveb.enabled then
begin
case
messagedlg('原始数据表中的数据已改变，是否保存？',mtconfirmation,mbyesnocancel,0)
of id_yes:begin
Form1.saveBClick(Sender);
if not sendb then
canclose:=false;;end;
id_no:;
id_cancel:canclose:=false;
end;
end;
end;



procedure TForm1.ENTER1Click(Sender: TObject);
begin
down:=0;
enter1.checked:=true;
end;

procedure TForm1.ENTER2Click(Sender: TObject);
begin
down:=1;
enter2.checked:=true;
end;

procedure TForm1.N6Click(Sender: TObject);
begin
optionform.showmodal;
end;

procedure TForm1.N7Click(Sender: TObject);
begin
memo2.Visible:=true;
memo2.top:=150;
memo2.Left:=250;
memo2.Height:=300;
memo2.Width:=300;
memo2.SetFocus;
end;

procedure TForm1.help2Click(Sender: TObject);
begin
Application.HelpJump('topic17');

end;

procedure TForm1.Memo2KeyDown(Sender: TObject
var Key: Word;
Shift: TShiftState);
begin
saveb.enabled:=true;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject
Col, Row: Integer;
var CanSelect: Boolean);
var vall:double;code:integer;
begin
if stringgrid1.cells[stringgrid1.col,stringgrid1.row]<>'' then
begin
val(stringgrid1.cells[stringgrid1.col,stringgrid1.row],vall,code);
if code<>0 then
begin
beep;
stringgrid1.cells[stringgrid1.col,stringgrid1.row]:='';

end;
end;
end;

procedure TForm1.StringGrid1Exit(Sender: TObject);
var i,j,col,row,code:integer;vall:double;
begin
col:=SpinEdit1.value;
row:=SpinEdit2.value;
for i:=1 to col+1 do
for j:=1 to row+1 do
if stringgrid1.cells[j,i]<>'' then
begin
val(stringgrid1.cells[j,i],vall,code);
if code<>0 then
begin
stringgrid1.cells[j,i]:='';
beep;
stringgrid1.SetFocus;
end;
end;
end;

procedure TForm1.Memo2Exit(Sender: TObject);
begin
memo2.Visible:=false;
end;

procedure TForm1.StringGrid1KeyPress(Sender: TObject
var Key: Char);
begin
if not(key in['0'..'9',#8,'.','-','e',#13])then
begin
key:=#0;
beep;
end;
if (key in['0'..'9',#8,'.','-'])then
begin
delete.enabled:=true;
saveb.enabled:=true;
d1.enabled:=true;
s1.enabled:=true;
end;

if key=#13 then
begin
if (stringgrid1.row=sedit1.value) and (stringgrid1.col=Sedit2.value) then
begin
beep;
exit;
end
else if down=1 then
begin
if stringgrid1.col=sedit2.value then
begin
stringgrid1.col:=1;
stringgrid1.row:=stringgrid1.row+1;
end
else
stringgrid1.col:=stringgrid1.col+1;
end //if down:=0
else//if down:=0
begin
if stringgrid1.row=sedit1.value then
begin
stringgrid1.row:=1;
stringgrid1.col:=stringgrid1.col+1;
end
else
stringgrid1.row:=stringgrid1.row+1;
end;//else//if down:=0
end;
end;

procedure TForm1.inrowClick(Sender: TObject);
var i,j:integer
//insert a row
begin
stringGrid1.RowCount:=stringGrid1.RowCount+1;
sedit1.Value:=sedit1.Value+1;
for i:=stringGrid1.RowCount-1 downto stringGrid1.row do
for j:= 1 to stringGrid1.colCount do
stringGrid1.cells[j,i+1]:=stringGrid1.cells[j,i];
for i:= 1 to stringGrid1.colCount do
stringGrid1.cells[i,stringGrid1.Row]:='';

end;

procedure TForm1.incolClick(Sender: TObject);
var i,j:integer
//insert a col
begin
stringGrid1.colCount:=stringGrid1.colCount+1;
sedit2.Value:=sedit2.Value+1;
for i:=stringGrid1.colCount-1 downto stringGrid1.col do
for j:= 1 to stringGrid1.rowCount do
stringGrid1.cells[i+1,j]:=stringGrid1.cells[i,j];
for i:= 1 to stringGrid1.rowCount do
stringGrid1.cells[stringGrid1.col,i]:='';
end;

procedure TForm1.delrowClick(Sender: TObject);
var i,j:integer;
begin
if messageDlg('真的要删除第'+intTostr(stringgrid1.row)+'行的所有数据',
mtwarning,[mbok,mbcancel],0)= id_ok
then begin
for i:=stringGrid1.row to stringGrid1.RowCount-1 do
for j:= 1 to stringGrid1.colCount do
stringGrid1.cells[j,i]:=stringGrid1.cells[j,i+1];
stringGrid1.RowCount:=stringGrid1.RowCount-1;
end;
end;

procedure TForm1.delcolClick(Sender: TObject);
var i,j:integer;
begin
if messageDlg('真的要删除第'+intTostr(stringgrid1.col)+'列的所有数据？',
mtwarning,[mbok,mbcancel],0)= id_ok
then begin
for i:=stringGrid1.col to stringGrid1.colCount-1 do
for j:= 1 to stringGrid1.rowCount do
stringGrid1.cells[i,j]:=stringGrid1.cells[i+1,j];
stringGrid1.colCount:=stringGrid1.colCount-1;
sedit2.Value:=sedit2.Value-1;
end;
end;

procedure TForm1.H1Click(Sender: TObject);
begin
if pagecontrol1.ActivePage=tabsheet1 then
application.HelpJump('topic2');
if pagecontrol1.ActivePage=tabsheet2 then
application.HelpJump('topic12');
if pagecontrol1.ActivePage=tabsheet3 then
application.HelpJump('topic16');
end;

procedure TForm1.searchClick(Sender: TObject);
begin
Memo1.setfocus;
Memo1.selStart:=1;
findDialog1.execute
end
//This procedure only open savedialog
//next procedure do the mission of seach
//*****************************************
procedure TForm1.FindDialog1Find(Sender: TObject);
var foundpos,Initpos:integer;
begin
initpos:=memo1.selstart+memo1.selLength;
foundpos:=pos(finddialog1.FindText,copy(memo1.text,
initpos+1,length(memo1.text)-initpos));
if foundpos>0 then
begin
Memo1.setfocus;
Memo1.selStart:=InitPos+FoundPos-1;
Memo1.selLength:=Length(FindDialog1.findText);
end
else begin
messagedlg('已经没有你要找的字符串!',
mtinformation,[mbOK],0)
end;
end;


procedure TForm1.searchnextClick(Sender: TObject);
begin
Form1.FindDialog1Find(Sender);
end;


end.
 
你的问题是用最小二乘法解解线性方程组，而不是线性规划法解线性方程组。
如下调用：
procedure TForm1.Button1Click(Sender: TObject);
var
A:TMatrix;
B:array[0..9] of Double;
x:array[0..4] of Double;
i:byte;
begin
SetLength(A, 10, 5);
A[0,0]:=74.5;
A[0,1]:=100.0;
A[0,2]:=100.0;
A[0,3]:=100.0;
A[0,4]:=100.0;
A[1,0]:=29.5;
A[1,1]:=98.1;
A[1,2]:=100.0;
A[1,3]:=100.0;
A[1,4]:=100.0;
A[2,0]:=0.7;
A[2,1]:=55.6;
A[2,2]:=100.0;
A[2,3]:=100.0;
A[2,4]:=100.0;
A[3,0]:=0;
A[3,1]:=0;
A[3,2]:=99.6;
A[3,3]:=100.0;
A[3,4]:=100.0;
A[4,0]:=0;
A[4,1]:=0;
A[4,2]:=61.7;
A[4,3]:=60.2;
A[4,4]:=100.0;
A[5,0]:=0;
A[5,1]:=0;
A[5,2]:=32.4;
A[5,3]:=31.9;
A[5,4]:=100.0;
A[6,0]:=0;
A[6,1]:=0;
A[6,2]:=20.4;
A[6,3]:=20.9;
A[6,4]:=100.0;
A[7,0]:=0;
A[7,1]:=0;
A[7,2]:=0;
A[7,3]:=11.9;
A[7,4]:=100.0;
A[8,0]:=0;
A[8,1]:=0;
A[8,2]:=0;
A[8,3]:=8.1;
A[8,4]:=97.0;
A[9,0]:=0;
A[9,1]:=0;
A[9,2]:=0;
A[9,3]:=5.3;
A[9,4]:=88.0;
B[0]:=95.0;
B[1]:=71.0;
B[2]:=57.5;
B[3]:=35;
B[4]:=25;
B[5]:=17.5;
B[6]:=13;
B[7]:=9.5;
B[8]:=7;
B[9]:=5;
MinSqrMul(10,5 ,A,B,X);
for i:=0 to 4 do showmessage(floatToStr(x));
end;
 
To:luyear
谢谢luyear这么慷慨大方，把所有原码都贴出来了，害我几天打不开。 ：-P
http://www.delphibbs.com/delphibbs/dispq.asp?lid=1017328
我不会亏侍你的，但是你把我的问题复杂化了，待我有时间再研究你的程序。

To:linsb
谢谢，我会及时去调试。等我好消息。
 
不行，与预期的结果不一样。（是一个例题）
结果是：
37.3 : 26.5 : 14.7 : 15.2 : 6.3
 
山木人你好啊！好久不见啊
你还记得我吗？
估计不记得了
但我记得你
在此问候你！
我道行还不够帮不了你不好意思
 
to 山木人
按你的要求给出调用解线性方程组函数的方法，你的预期结果不知从何而来，和方程组的
解可能不是一回事。也许你没有表达清楚你的要求，那可把我们逗苦了！！！
 
To: alol
我还真不记得你是谁了，能告诉我吗？我的

To: linsb
绝对没有逗你们吃苦的意思。"你的预期结果不知从何而来"是一个例题。
公式：∑（A[i,j]*X）=B[j]
数据：如第一贴，A，B
求：X
这个解不了，对我学习Delphi算是一大打击，希望你能帮我，谢谢。

 
to 山木人
我没弄清你的问题，你的实际问题是什么？是个回归分析还是线性规划？你的例题又是什么？
可把详细情况写给我，我可以帮你分析一下。
linsb3031@0451.com
 
我尽快整理出来。
 
多人接受答案了。
 
您必须登录或注册才可回复。

Similar threads

L
JohnsonGuo在不在？关于最小二乘法(10分)
回复
13
查看
224
lcl_003
L
春
求解线性规划中的单纯型法的源码(100分)
2
回复
36
查看
468
春风江南
春
L
多元线性回归和线性规划的pascal算法，倾分请教！(200分)
2
回复
20
查看
253
lj.ah
L
L
请教：多线程连接数据库，如何传递connection问题(200分)
回复
12
查看
232
bluebird
B
天
我这里有一份试卷，很简单的，谁能帮解答一下！急！！！！我还要答别的卷，谁能帮一下！(100分)
回复
7
查看
362
天崖无爱
天
后退
顶部