逐步判别m2.bas

<VB数理统计实用算法>书中的算法源程序

Attribute VB_Name = "modMethod"
'逐步判别
Option Explicit
'计算判别系数和马哈拉诺比斯距离
Public Sub CalCoeD2(N As Integer, L As Integer, X() As Double, W() As Double, _
            Mx() As Double, C() As Double, D2hg() As Double, Ng() As Double, _
            Fhg() As Double)
    Dim C0 As Double, Ci As Double, D As Double, D2 As Double
    Dim I As Integer, J As Integer, K As Integer, H As Integer
    Dim G As Integer, M As Integer
    G = UBound(Ng, 1): M = UBound(X, 1)                 'G是分类数，M是变量数
    For H = 1 To G
        C0 = 0
        For I = 1 To M
            Ci = 0
'X(i) = 0 表示为未选量，否则已选
            If X(I) <> 0 Then
                For J = 1 To M
                    If X(J) <> 0 Then Ci = Ci + W(I, J) * Mx(H, J)
                Next J
            End If
            C(H, I) = (N - G) * Ci
            C0 = C0 + Ci * Mx(H, I)
        Next I
        C(H, 0) = -C0 * (N - G) / 2
    Next H
    D = 0
    For H = 2 To G
        For K = 1 To H - 1
            D = D + 1: D2 = 0
            For I = 1 To M
                If X(I) <> 0 Then D2 = D2 + _
                    (C(H, I) - C(K, I)) * (Mx(H, I) - Mx(K, I))
                D2hg(D) = D2                            '马哈拉诺比斯距离
                Fhg(D) = D2 * ((N - G - L + 1) * Ng(H) * Ng(K) _
                    / (L * (N - G) * (Ng(H) + Ng(K))))  'F检验值
            Next I
        Next K
    Next H
End Sub

'分类，并计算后验概率和判别矩阵Dm
Public Sub Class(XY() As Double, X() As Double, C() As Double, _
        LnQ() As Double, Pr() As Double, Dm() As Double, _
        New_Sort() As Double)
    Dim I As Integer, J As Integer, K As Integer, H As Integer
    Dim N As Integer, M As Integer, M1 As Integer
    Dim G As Integer, G1 As Integer
    Dim Yh As Double, Ymax As Double, Hmax As Double
    Dim D As Double, D1 As Double, D2 As Double
    N = UBound(XY, 1): G = UBound(C, 1): M = UBound(X, 1)
    M1 = M + 1: G1 = G + 1
    For K = 1 To N
        Ymax = -1000000
        For H = 1 To G
            Yh = LnQ(H) + C(H, 0)
            For I = 1 To M
                If X(I) <> 0 Then Yh = Yh + C(H, I) * XY(K, I)
            Next I
            Pr(H) = Yh                  '判别函数
            If Yh > Ymax Then
                Ymax = Yh: Hmax = H
            End If
        Next H
        D = 0
        For H = 1 To G
            Pr(H) = Exp(Pr(H) - Ymax)
            D = D + Pr(H)
        Next H
        Ymax = Pr(Hmax) / D             '后验概率
        H = XY(K, M1)                   '原来分类
        Dm(Hmax, H) = Dm(Hmax, H) + 1   '形成判别矩阵
' "原来分类" = H, "新分类" = Hmax, "后验概率" = Ymax
        New_Sort(K, 1) = H: New_Sort(K, 2) = Hmax: New_Sort(K, 3) = Ymax
    Next K
    For H = 1 To G
        D1 = 0: D2 = 0
        For K = 1 To G
            D1 = D1 + Dm(H, K)
            D2 = D2 + Dm(K, H)
        Next K
        Dm(H, G1) = D1: Dm(G1, H) = D2
    Next H
    Dm(G1, G1) = N
End Sub