www.pudn.com > zhubuhuigui.rar > 逐步回归M2.bas, change:2006-03-10,size:12494b
Attribute VB_Name = "modMethod"
'逐步回归
Option Explicit
'xy(1 To n, 1 To m+1)：观测数据，已知，n是观测次数，m是自变量个数
'F1：指定的F临界值，用于引入，已知
'F2：指定的F临界值，用于剔出，已知
' 要求F1>=F2。如果F1=F2=0，则引入除线性相关外的全部变量
'F：F检验值，计算结果
'L：选出的重要变量的个数，计算结果
'b(0 To m)：回归系数，计算结果
'Ti(1 To m)：各变量的t检验值，计算结果
Public Sub Strd(xy() As Double, F1 As Double, F2 As Double, F As Double, _
L As Integer, b() As Single, Ti() As Single)
Dim I As Integer, J As Integer, K As Integer
Dim n As Integer, m As Integer, y As Integer
Dim Imax As Integer, Imin As Integer
Dim Ry12m As Double, Sy As Double, Syy As Double, V As Double, ss As Single
Dim F12 As Double, K12 As Integer
Dim Mx(1 To 101) As Double, Vx(1 To 101) As Double, Vyx(1 To 101) As Double
Dim R(1 To 101, 1 To 101) As Double, Ri(1 To 101) As Double
Dim d As Double, Sp As Integer, Q As Double, Vmax As Double, Vmin As Double
Dim Bi As Double
n = UBound(xy, 1) 'N是观测数据的组数，即x数组的行数
y = UBound(xy, 2) 'y是自变量+因变量的个数，即x数组的列数
m = y - 1 'm是自变量的个数
'求平均值，保存于Mx()
Debug.Print "平均数"
Debug.Print "X1", "X2", "X3", "X4", "Y"
For I = 1 To y
d = 0
For K = 1 To n
d = xy(K, I) + d
Next K
Mx(I) = d / n
Debug.Print Mx(I),
Next I
'计算离差矩阵，放在R的下三角部分
For K = 1 To n
For I = 1 To y
d = xy(K, I) - Mx(I): Vx(I) = d
For J = 1 To I
R(I, J) = d * Vx(J) + R(I, J)
Next J
Next I
Next K
For I = 1 To y
Syy = R(I, I)
If Syy = 0 Then
MsgBox "某变量为常数，无法计算相关系数！"
Exit Sub
Else
Vx(I) = Sqr(Syy)
End If
Next I
'计算相关矩阵，放在R的上三角部分
For I = 2 To y
d = Vx(I)
For J = 1 To I - 1
R(J, I) = R(I, J) / (d * Vx(J))
Next J
Next I
Debug.Print ""
Debug.Print "标准差"
Debug.Print "X1", "X2", "X3", "X4", "Y"
d = Sqr(1 / (n - 1))
For I = 1 To y
Vx(I) = d * Vx(I)
ss = Vx(I)
Debug.Print ss,
Vyx(I) = R(I, y)
Next I
Debug.Print ""
Debug.Print "相关系数"
For I = 1 To y
R(I, I) = 1: Vyx(I) = Vx(y) / Vx(I)
For J = I + 1 To y
R(J, I) = R(I, J)
Next J
Next I
For I = 1 To y
For J = 1 To y
ss = R(I, J)
Debug.Print ss,
Next J
Debug.Print ""
Next I
'法方程已建立，下面进入逐步计算
'计算各变量的贡献V，从已入选的变量中找出最小的V，从未选量中找出最大的V
L2:
L = 0: Sp = 0: Q = 1
LStep:
Sp = Sp + 1: Vmax = 0: Vmin = 10
For I = 1 To m
Ti(I) = 0: d = R(I, I)
If d > 0.00000001 Then
V = (R(y, I) / d) * R(I, y)
If V 0 Then
Ti(I) = d
If -V Vmin Then
Vmin = -V: Imin = I
End If
Else
If V > Vmax Then
Vmax = V: Imax = I
End If
End If
End If
Next I
If L <> 0 Then
d = 0
For I = 1 To m
If Ti(I) = 0 Then
b(I) = 0: Ri(I) = 0
Else
Bi = R(I, y): b(I) = Vyx(I) * Bi
d = d + b(I) * Mx(I)
Ri(I) = Bi / Sqr(Ti(I) * Q + Bi ^ 2)
Ti(I) = Bi / Sqr(Ti(I) * Q / (n - L - 1))
End If
Next I
b(0) = Mx(y) - d
End If
F12 = (n - L - 1) * Vmin / Q
If F12 F2 Then
L = L - 1: K = Imin: K12 = -K
Else
F12 = (n - L - 2) * Vmax / (Q - Vmax)
If F12 = (F1 + 0.00000001) Then
GoTo L3
Else
L = L + 1: K = Imax: K12 = K
End If
End If
'下面对R矩阵的第K列作消去计算
d = 1 / R(K, K): R(K, K) = 1
For J = 1 To y
R(K, J) = R(K, J) * d
Next J
For I = 1 To y
If I = K Then
Else
d = R(I, K): R(I, K) = 0
For J = 1 To y
R(I, J) = R(I, J) - d * R(K, J)
Next J
End If
Next I
Q = R(y, y): Ry12m = Sqr(1 - Q)
F = (n - L - 1) * (1 - Q) / (L * Q)
Sy = Sqr(Syy * Q / (n - L - 1))
GoTo LStep
L3:
If L = 0 Then
MsgBox "在当前的F1、F2下，不能选出重要的变量！"
Exit Sub
End If
d = 0
For I = 1 To m
If Ti(I) = 0 Then
b(I) = 0: Ri(I) = 0
Else
Bi = R(I, y): b(I) = Vyx(I) * Bi
d = d + b(I) * Mx(I)
Ri(I) = Bi / Sqr(Abs(Ti(I) * Q + Bi ^ 2))
Ti(I) = Bi / Sqr(Abs(Ti(I) * Q / (n - L - 1)))
Ti(I) = Abs(Ti(I))
End If
Next I
Debug.Print "最后的相关系数"
For I = 1 To y - 1
For J = 1 To y
ss = R(I, J)
Debug.Print ss,
Next J
Debug.Print ""
Next I
b(0) = Mx(y) - d
End Sub
'求正态分布的分位数
'Q：上侧概率
'x：分位数
Public Sub PNorm(Q, x)
Dim p As Double, y As Double, z As Double
Dim b0 As Double, b1 As Double, b2 As Double
Dim b3 As Double, b4 As Double, b5 As Double
Dim b6 As Double, b7 As Double, b8 As Double
Dim b9 As Double, b10 As Double, b As Double
b0 = 1.570796288: b1 = 0.03706987906
b2 = -0.0008364353589: b3 = -0.0002250947176
b4 = 0.000006841218299: b5 = 0.000005824238515
b6 = -0.00000104527497: b7 = 8.360937017E-08
b8 = -3.231081277E-09: b9 = 3.657763036E-11
b10 = 6.936233982E-13
If Q = 0.5 Then
x = 0: GoTo PN01
End If
If Q > 0.5 Then p = 1 - Q Else p = Q
y = -Log(4 * p * (1 - p))
b = y * (b9 + y * b10)
b = y * (b8 + b): b = y * (b7 + b)
b = y * (b6 + b): b = y * (b5 + b)
b = y * (b4 + b): b = y * (b3 + b)
b = y * (b2 + b): b = y * (b1 + b)
z = y * (b0 + b): x = Sqr(z)
If Q > 0.5 Then x = -x
PN01:
End Sub
'计算F分布的分布函数
'n1：自由度，已知
'n2：自由度，已知
'F：F值，已知
'p：下侧概率，所求
'd：概率密度，所求
Public Sub F_DIST(n1 As Integer, n2 As Integer, F As Double, _
p As Double, d As Double)
Dim x As Double, U As Double, Lu As Double
Dim IAI As Integer, IBI As Integer, nn1 As Integer, nn2 As Integer
Dim I As Integer
Const PI As Double = 3.14159265359
If F = 0 Then
p = 0: d = 0: Exit Sub
End If
x = n1 * F / (n2 + n1 * F)
If (n1 \ 2) * 2 = n1 Then
If (n2 \ 2) * 2 = n2 Then
U = x * (1 - x): p = x: IAI = 2: IBI = 2
Else
U = x * Sqr(1 - x) / 2: p = 1 - Sqr(1 - x): IAI = 2: IBI = 1
End If
Else
If (n2 \ 2) * 2 = n2 Then
p = Sqr(x): U = p * (1 - x) / 2: IAI = 1: IBI = 2
Else
U = Sqr(x * (1 - x)) / PI
p = 1 - 2 * Atn(Sqr((1 - x) / x)) / PI: IAI = 1: IBI = 1
End If
End If
nn1 = n1 - 2: nn2 = n2 - 2
If U = 0 Then
d = U / F
Exit Sub
Else
Lu = Log(U)
End If
If IAI = n1 Then GoTo LL1
For I = IAI To nn1 Step 2
p = p - 2 * U / I
Lu = Lu + Log((1 + IBI / I) * x)
U = Exp(Lu)
Next I
LL1:
If IBI = n2 Then
d = U / F: Exit Sub
End If
For I = IBI To nn2 Step 2
p = p + 2 * U / I
Lu = Lu + Log((1 + n1 / I) * (1 - x))
U = Exp(Lu)
Next I
d = U / F
End Sub
'计算F分布的分位数
'n1：自由度，已知
'n2：自由度，已知
'Q：上侧概率，已知
'F：分位数，所求
Public Sub PF_DIST(n1 As Integer, n2 As Integer, _
Q As Double, F As Double)
Dim DF12 As Double, DF22 As Double, a As Double, b As Double
Dim A1 As Double, b1 As Double, p As Double, YQ As Double
Dim E As Double, FO As Double, pp As Double, d As Double
Dim GA1 As Double, GA2 As Double, GA3 As Double
Dim K As Integer
DF12 = n1 / 2: DF22 = n2 / 2
a = 2 / (9 * n1): A1 = 1 - a
b = 2 / (9 * n2): b1 = 1 - b
p = 1 - Q: PNorm Q, YQ
E = b1 * b1 - b * YQ * YQ
If E > 0.8 Then
FO = ((A1 * b1 + YQ * Sqr(A1 * A1 * b + a * E)) / E) ^ 3
Else
lnGamma DF12 + DF22, GA1
lnGamma DF12, GA2
lnGamma DF22, GA3
FO = (2 / n2) * (GA1 - GA2 - GA3 + 0.69315 + (DF22 - 1) * Log(n2) _
- DF22 * Log(n1) - Log(Q))
FO = Exp(FO)
End If
For K = 1 To 30
F_DIST n1, n2, FO, pp, d
If d = 0 Then
F = FO: Exit Sub
End If
F = FO - (pp - p) / d
If Abs(FO - F) 0.000001 * Abs(F) Then Exit Sub Else FO = F
Next K
End Sub
'计算GAMMA函数
'x：自变量
'z：GAMMA函数值
Public Sub GAMMA(x As Double, z As Double)
Dim H As Double, y As Double, y1 As Double
H = 1: y = x
LL1:
If y = 2 Then
z = H
Exit Sub
ElseIf y 2 Then
H = H / y: y = y + 1: GoTo LL1
ElseIf y >= 3 Then
y = y - 1: H = H * y: GoTo LL1
End If
y = y - 2
y1 = y * (0.005159 + y * 0.001606)
y1 = y * (0.004451 + y1)
y1 = y * (0.07211 + y1)
y1 = y * (0.082112 + y1)
y1 = y * (0.41174 + y1)
y1 = y * (0.422787 + y1)
H = H * (0.999999 + y1)
z = H
End Sub
'求Gamma函数的对数LogGamma(x)
'x：自变量
'G：Gamma函数的对数
Public Sub lnGamma(x As Double, G As Double)
Dim y As Double, z As Double, a As Double
Dim b As Double, b1 As Double, n As Integer
Dim I As Integer
If x 8 Then
y = x + 8: n = -1
Else
y = x: n = 1
End If
z = 1 / (y * y)
a = (y - 0.5) * Log(y) - y + 0.9189385
b1 = (0.0007663452 * z - 0.0005940956) * z
b1 = (b1 + 0.0007936431) * z
b1 = (b1 - 0.002777778) * z
b = (b1 + 0.0833333) / y
G = a + b
If n >= 0 Then Exit Sub
y = y - 1: a = y
For I = 1 To 7
a = a * (y - I)
Next I
G = G - Log(a)
End Sub
'计算t分布的分布函数
'n：自由度，已知
'T：t值，已知
'pp：下侧概率，所求
'dd：概率密度，所求
Public Sub T_Dist(n As Integer, t As Double, pp As Double, dd As Double)
Dim Sign As Integer, TT As Double, x As Double
Dim p As Double, U As Double, GA1 As Double, GA2 As Double
Dim IBI As Integer, n2 As Integer, I As Integer
Const PI As Double = 3.14159265359
If t = 0 Then
Call GAMMA(n / 2, GA1): Call GAMMA(n / 2 + 0.5, GA2): pp = 0.5
dd = GA2 / (Sqr(n * PI) * GA1): Exit Sub
End If
If t 0 Then Sign = -1 Else Sign = 1
TT = t * t: x = TT / (n + TT)
If (n \ 2) * 2 = n Then 'n为偶数
p = Sqr(x): U = p * (1 - x) / 2
IBI = 2
Else 'n为奇数
U = Sqr(x * (1 - x)) / PI
p = 1 - 2 * Atn(Sqr((1 - x) / x)) / PI
IBI = 1
End If
If IBI = n Then GoTo LL1 Else n2 = n - 2
For I = IBI To n2 Step 2
p = p + 2 * U / I
U = U * (1 + I) / I * (1 - x)
Next I
LL1:
dd = U / Abs(t)
pp = 0.5 + Sign * p / 2
End Sub
'求t分布的分位数
'n：自由度，已知
'Q：上侧概率（=0.5），已知
'T：分位数，所求
Public Sub PT_DIST(n As Integer, Q As Double, t As Double)
Dim PIS As Double, DFR2 As Double, c As Double
Dim Q2 As Double, p As Double, YQ As Double, E As Double
Dim GA1 As Double, GA2 As Double, GA3 As Double
Dim T0 As Double, pp As Double, d As Double
Dim K As Integer
Const PI As Double = 3.14159265359
PIS = Sqr(PI): DFR2 = n / 2
If n = 1 Then
t = Tan(PI * (0.5 - Q)): Exit Sub
End If
If n = 2 Then
If Q > 0.5 Then c = -1 Else c = 1
Q2 = (1 - 2 * Q) ^ 2
t = Sqr(2 * Q2 / (1 - Q2)) * c
Exit Sub
End If
p = 1 - Q: PNorm Q, YQ '正态分布分位数
E = (1 - 1 / (4 * n)) ^ 2 - YQ * YQ / (2 * n)
If E > 0.5 Then
T0 = YQ / Sqr(E)
Else
lnGamma DFR2, GA1: lnGamma DFR2 + 0.5, GA2
GA3 = Exp((GA1 - GA2) / n)
T0 = Sqr(n) / (PIS * Q * n) ^ (1 / n) / GA3
End If
For K = 1 To 30
T_Dist n, T0, pp, d
If d = 0 Then
t = T0: Exit Sub
End If
t = T0 - (pp - p) / d
If Abs(T0 - t) 0.000001 * Abs(t) Then _
Exit Sub Else T0 = t
Next K
End Sub