最小二乘法多次曲线拟合算法

首先介绍多元线性回归公式（即最小二乘法计算公式）：
回归公式：f(Ｘ1,Ｘ2,…,Ｘk)=Ｙ=Ａ0+Ａ1Ｘ1+…+ＡkＸk
要求：{∑[Ｙ-(Ａ0+Ａ1Ｘ1+…+ＡkＸk)]^2}min
Ｎ为输入数据个数，输入数据为：Ｘ1,Ｘ2,…,Ｘk,Ｙ
设：
Ｌij=∑ＸiＸj-∑Ｘi∑Ｘj/Ｎ
Ｌiy=∑ＸiＹ-∑Ｘi∑Ｙ/Ｎ
Ｌyy=∑Ｙ^2-∑Ｙ∑Ｙ/Ｎ
注：∑Ｘi表示输入数据中所有Ｘi的和，∑ＸiＸj表示每次输入数据中的ＸiＸj的积的和

则Ａ0,Ａ1,…,Ａk满足方程组：
Ａ0=(∑Ｙ-Ａ1∑Ｘ1-…-Ａk∑Ｘk)/Ｎ
┌Ｌ11Ａ1+Ｌ12Ａ2+…+Ｌ1kＡk=Ｌ1y
│Ｌ21Ａ1+Ｌ22Ａ2+…+Ｌ2kＡk=Ｌ2y
┤ ： ： ：
│ ： ： ：
└Ｌk1Ａ1+Ｌk2Ａ2+…+ＬkkＡk=Ｌky
解此方程组，于是Ａ0、Ａ1、……、Ａk便为回归系数。
若把回归公式改为：f(Ｘ)=Ｙ=Ａ0+Ａ1Ｘ+Ａ2Ｘ^2+…+ＡkＸ^k
这样一来就变成我需要的多次曲线拟合算法。
详细代码如下（主函数为GetMINNHvalue）：
'=======================================================================
'hRoot()--------双精度一维数组
' 指定回归公式，如hRoot(3)=1则表明回归公式中有三次项
' hRoot(2)=0则表明回归公式中没有二次项
'hMaxIndex------指定hRoot()的最大下标，最小为0
'hData()--------双精度二维数组，第二维从0至1
' 点的坐标数据
'LenData--------指定点的个数，即hData()第一维的最大下标
'解出的回归系数保存在hRoot()中，返回值为相关系数（若为负则出错）
'-----------------------------------------------------------------------
Public Function GetMINNHvalue(hRoot() As Double, hMaxIndex As Long, hData() As Double, ByVal LenData As Long) As Long
Dim d1 As Double, D2 As Double, d3 As Double
Dim z1 As Long, z2 As Long, z3 As Long
Dim zfx As Long, zfy As Long
Dim Sum() As Double, data() As Double, FC() As Double, Root() As Double
z2 = 0
For z1 = 1 To hMaxIndex
If hRoot(z1) <> 0 Then z2 = z2 + 1
Next
'=============================================================================
zfx = z2: zfy = LenData
ReDim Sum(zfx, zfy - 1) As Double, data(zfy - 1) As Double
'-----------------------------------------------------------------------------
For z1 = 0 To zfy - 1
data(z1) = hData(z1, 0)
Sum(zfx, z1) = hData(z1, 1)
Next
z3 = 0
For z2 = 0 To zfx - 1
z3 = z3 + 1
BegIF1: If hRoot(z3) = 0 Then z3 = z3 + 1: GoTo BegIF1
For z1 = 0 To zfy - 1
d1 = data(z1)
Sum(z2, z1) = d1 ^ z3
Next
Next
'------------------------------------------------------------------------------
ReDim FC(zfx + 1, zfx) As Double, Root(zfx + 1) As Double
For z2 = 0 To zfx
For z1 = 0 To zfx
d1 = 0: D2 = 0: d3 = 0
For z3 = 0 To zfy - 1
d1 = d1 + Sum(z1, z3) * Sum(z2, z3)
D2 = D2 + Sum(z1, z3)
d3 = d3 + Sum(z2, z3)
Next
FC(z1, z2) = d1 - D2 * d3 / zfy
Next
Next
'------------------------------------------------------------------------------
Call ExplainEquation(FC(), Root(), zfx - 1)
If Root(zfx) = 0 Then GetMINNHvalue = -1: Exit Function
On Error GoTo ED
d1 = 0
For z1 = 0 To zfy - 1
d1 = d1 + Sum(zfx, z1)
Next
For z2 = 0 To zfx - 1
D2 = 0
For z1 = 0 To zfy - 1
D2 = D2 + Sum(z2, z1)
Next
d1 = d1 - D2 * Root(z2) / Root(zfx)
Next
hRoot(0) = d1 / zfy
z1 = 0
For z2 = 1 To hMaxIndex
If hRoot(z2) <> 0 Then
hRoot(z2) = Root(z1) / Root(zfx)
z1 = z1 + 1
End If
Next
d1 = 0
For z1 = 0 To zfx - 1
d1 = d1 + Root(z1) * FC(zfx, z1)
Next
GetMINNHvalue = Sqr(d1 / Root(zfx) / FC(zfx, zfx))
On Error GoTo 0
Exit Function
ED:
GetMINNHvalue = -2
End Function
'========================================================================
'行列式求值函数
'------------------------------------------------------------------------
Public Function GetHLValue(n() As Double, ByVal nWide As Long) As Double
Dim nt(127) As Double
Dim z1 As Long, z2 As Long, z3 As Double, z4 As Double, z5 As Double
If nWide > 2 Then
z5 = 0
For z1 = 0 To nWide - 1
z4 = n(z1, nWide)
If z4 = 0 Then GoTo NE
For z2 = 0 To nWide '- 1
nt(z2) = n(z1, z2)
n(z1, z2) = n(nWide, z2)
Next z2
z3 = GetHLValue(n(), nWide - 1)
For z2 = 0 To nWide '- 1
n(z1, z2) = nt(z2)
Next z2
If ((nWide) Mod 2) = 1 Then z5 = z5 + z3 * z4 Else z5 = z5 - z3 * z4
NE:
Next z1
z3 = GetHLValue(n(), nWide - 1)
If ((nWide) Mod 2) = 0 Then
GetHLValue = z5 + n(nWide, nWide) * z3
Else
GetHLValue = z5 - n(nWide, nWide) * z3
End If
Exit Function
End If
If nWide = 2 Then
For z2 = 0 To nWide
z3 = 1: z4 = 1
For z1 = 0 To nWide
z3 = z3 * n((z2 + z1) Mod (nWide + 1), z1)
z4 = z4 * n((z2 - z1 + nWide + 1) Mod (nWide + 1), z1)
Next z1
GetHLValue = GetHLValue + z3 - z4
Next z2
ElseIf nWide = 1 Then
GetHLValue = n(0, 0) * n(1, 1) - n(0, 1) * n(1, 0)
ElseIf nWide = 0 Then
GetHLValue = n(0, 0)
End If
End Function
'========================================================================
'求两数的最大公约数
'------------------------------------------------------------------------
Public Function GetZZXCvalue(ByVal N1 As Long, ByVal N2 As Long) As Long
Dim z1 As Long
N1 = Abs(N1): N2 = Abs(N2)
If N1 < N2 Then z1 = N1 Else z1 = N2
If z1 = 0 Then
GetZZXCvalue = N1 + N2
If GetZZXCvalue = 0 Then GetZZXCvalue = 1
Exit Function
End If
If z1 = 1 Then GetZZXCvalue = 1: Exit Function
Begin:
If N1 < N2 Then
N2 = N2 Mod N1
If N2 = 0 Then GetZZXCvalue = N1: Exit Function
Else
N1 = N1 Mod N2
If N1 = 0 Then GetZZXCvalue = N2: Exit Function
End If
GoTo Begin
End Function
'=======================================================================
'求解多元线性方程组
'-----------------------------------------------------------------------
Public Function ExplainEquation(FC() As Double, Root() As Double, ByVal Height As Long)
Dim z1 As Long, z2 As Long
Root(Height + 1) = GetHLValue(FC(), Height)
For z1 = 0 To Height
For z2 = 0 To Height
FC(Height + 2, z2) = FC(z1, z2)
FC(z1, z2) = FC(Height + 1, z2)
Next z2
Root(z1) = GetHLValue(FC(), Height)
For z2 = 0 To Height
FC(z1, z2) = FC(Height + 2, z2)
Next z2
Next z1
For z1 = 0 To Height + 1
If Root(z1) <> Int(Root(z1)) Then Exit Function
Next
z2 = GetZZXCvalue(Root(0), Root(1))
For z1 = 0 To Height
z2 = GetZZXCvalue(z2, Root(z1 + 1))
Next z1
If Root(Height + 1) < 0 Then z2 = -z2
For z1 = 0 To Height + 1
Root(z1) = Root(z1) / z2
Next z1
End Function
望各位多提宝贵意见[email="Z_Jumping@163.com"]Z_Jumping@163.com[/email]
完整程序及源代码下载：请单击此处