模糊聚类m3.bas

模糊数学中模糊聚类算法的vb实现

Attribute VB_Name = "modMethod"
'模糊聚类分析
'标定方法、传递闭包法、相似性检查
Option Explicit
'数量积法
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
'dbM为用户提供的M参数
Public Sub M1(X() As Double, R() As Double, dbM As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim S As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                S = 0
                For K = 1 To M
                    S = S + X(I, K) * X(J, K)
                Next K
                R(I, J) = Int((S / dbM) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub

'夹角余弦法
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To M)：相似矩阵，N为样本数
Public Sub M2(X() As Double, R() As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim S1 As Double, Si2 As Double, Sj2 As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                S1 = 0: Si2 = 0: Sj2 = 0
                For K = 1 To M
                    S1 = S1 + X(I, K) * X(J, K)
                    Si2 = Si2 + X(I, K) ^ 2
                    Sj2 = Sj2 + X(J, K) ^ 2
                Next K
                R(I, J) = Int((S1 / Sqr(Si2 * Sj2)) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub
    
'相关分析法
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
Public Sub M3(X() As Double, R() As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim Xia As Double, Xja As Double
    Dim S1 As Double, Si2 As Double, Sj2 As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                Xia = 0: Xja = 0
                For K = 1 To M
                    Xia = Xia + X(I, K)
                    Xja = Xja + X(J, K)
                Next K
                Xia = Xia / M: Xja = Xja / M
                S1 = 0: Si2 = 0: Sj2 = 0
                For K = 1 To M
                    S1 = S1 + Abs(X(I, K) - Xia) * Abs(X(J, K) - Xja)
                    Si2 = Si2 + (X(I, K) - Xia) ^ 2
                    Sj2 = Sj2 + (X(J, K) - Xja) ^ 2
                Next K
                R(I, J) = Int((S1 / Sqr(Si2 * Sj2)) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub

'指数相似系数法
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
Public Sub M4(X() As Double, R() As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim Xka As Double, Sk2(1 To 200) As Double
    Dim E As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For K = 1 To M
        Xka = 0
        For I = 1 To N
            Xka = Xka + X(I, K)
        Next I
        Xka = Xka / N                           '平均值
        Sk2(K) = 0
        For I = 1 To N
            Sk2(K) = Sk2(K) + (X(I, K) - Xka) ^ 2
        Next I
        Sk2(K) = Sk2(K) / N                     '平均方差
    Next K
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                E = 0
                For K = 1 To M
                    E = E + Exp(-0.75 * (X(I, K) - X(J, K)) ^ 2 / Sk2(K))
                Next K
                R(I, J) = Int((E / M) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub

'最大最小法
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
Public Sub M5(X() As Double, R() As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim R1 As Double, R2 As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                R1 = 0: R2 = 0
                For K = 1 To M
                    If X(I, K) < X(J, K) Then _
                        R1 = R1 + X(I, K) Else R1 = R1 + X(J, K)
                    If X(I, K) > X(J, K) Then _
                        R2 = R2 + X(I, K) Else R2 = R2 + X(J, K)
                Next K
                R(I, J) = Int((R1 / R2) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub

'算术平均值最小法
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
Public Sub M6(X() As Double, R() As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim R1 As Double, R2 As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                R1 = 0: R2 = 0
                For K = 1 To M
                    If X(I, K) < X(J, K) Then _
                        R1 = R1 + X(I, K) Else R1 = R1 + X(J, K)
                    R2 = R2 + X(I, K) + X(J, K)
                Next K
                R(I, J) = Int((2 * R1 / R2) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub
    
'几何平均值最小法
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
Public Sub M7(X() As Double, R() As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim R1 As Double, R2 As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                R1 = 0: R2 = 0
                For K = 1 To M
                    If X(I, K) < X(J, K) Then _
                        R1 = R1 + X(I, K) Else R1 = R1 + X(J, K)
                    R2 = R2 + Sqr(X(I, K) * X(J, K))
                Next K
                R(I, J) = Int((R1 / R2) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub

'绝对值倒数法
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
'dbM为用户提供的M参数
Public Sub M8(X() As Double, R() As Double, dbM As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim S As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                S = 0
                For K = 1 To M
                    S = S + Abs(X(I, K) - X(J, K))
                Next K
                R(I, J) = Int((dbM / S) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub

'绝对值指数法
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
Public Sub M9(X() As Double, R() As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim S As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                S = 0
                For K = 1 To M
                    S = S + Abs(X(I, K) - X(J, K))
                Next K
                R(I, J) = Int(Exp(-S) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub

'海明距离
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
'dbC：用户提供的C参数
Public Sub M11(X() As Double, R() As Double, dbC As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim d As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                d = 0
                For K = 1 To M
                    d = d + Abs(X(I, K) - X(J, K))
                Next K
                R(I, J) = Int((1 - dbC * d) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub

'欧氏距离
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
'dbC：用户提供的C参数
Public Sub M12(X() As Double, R() As Double, dbC As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim d As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                d = 0
                For K = 1 To M
                    d = d + (X(I, K) - X(J, K)) ^ 2
                Next K
                R(I, J) = Int((1 - dbC * Sqr(d)) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub

'切氏距离
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
'dbC：用户提供的C参数
Public Sub M13(X() As Double, R() As Double, dbC As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim d As Double
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                d = 0
                For K = 1 To M
                    If Abs(X(I, K) - X(J, K)) > d Then d = Abs(X(I, K) - X(J, K))
                Next K
                R(I, J) = Int((1 - dbC * d) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub
   
'海明加权，仅适用于特例
'X(1 To N,1 To M)：观测数据，N为样本数，M为指标数
'R(1 To N,1 To N)：相似矩阵，N为样本数
'dbC：用户提供的C参数
Public Sub M14(X() As Double, R() As Double, dbC As Double)
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim d As Double, cc(1 To 200) As Single
    N = UBound(X, 1): M = UBound(X, 2)          'N:样品数；M:指标数
'*****************************************************************************
    For I = 1 To M                              'cc是权
        cc(I) = ((M + 1) - I) / 10              '这里的权仅对特例有效
    Next I                                      '如果遇到其他加权形式需进行修改
'*****************************************************************************
    For I = 1 To N
        For J = 1 To N
            If I = J Then R(I, J) = 1
            If I <> J Then
                d = 0
                For K = 1 To M
                    d = d + cc(K) * Abs(X(I, K) - X(J, K))
                Next K
                R(I, J) = Int((1 - dbC * d) * 1000 + 0.5) / 1000
            End If
        Next J
    Next I
End Sub
    
'检查矩阵R是否满足相似条件
'R(1 To N,1 To N)：待检查矩阵，N为样本数
Public Function CheckR(R() As Double) As Integer
    Dim M As Integer, N As Integer
    Dim I As Integer, J As Integer
    N = UBound(R, 1): M = UBound(R, 2)
    If M <> N Then
        CheckR = 0
        MsgBox "行数和列数不等", , "相似矩阵错误"
        Exit Function
    End If
    For I = 1 To N
        If R(I, I) <> 1 Then
            CheckR = 0
            MsgBox "不满足自反性", , "相似矩阵错误"
            Exit Function
        End If
    Next I
    For I = 1 To N
        For J = 1 To N
            If R(I, J) <> R(J, I) Then
                CheckR = 0
                MsgBox "不满足对称性", , "相似矩阵错误"
                Exit Function
            End If
        Next J
    Next I
    For I = 1 To N
        For J = 1 To N
            If R(I, J) > 1 Then
                CheckR = 0
                MsgBox "元素值大于1", , "相似矩阵错误"
                Exit Function
            End If
        Next J
    Next I
    For I = 1 To N
        For J = 1 To N
            If R(I, J) < 0 Then
                CheckR = 0
                MsgBox "元素值小于0", , "相似矩阵错误"
                Exit Function
            End If
        Next J
    Next I
    CheckR = 1
End Function

'传递闭包法
'r(1 To N,1 To N)：相似矩阵，N为样本数
'rr(1 To N,1 To N)：模糊乘积矩阵，N为样本数
Public Sub tR(R() As Double, RR() As Double)
    Dim N As Integer, L As Integer
    Dim I As Integer, J As Integer, K As Integer
    Dim I1 As Integer, J1 As Integer
    Dim dMin(1 To 1000) As Double, dMax As Double
    N = UBound(R, 1)                            'N:样品数
    L = 0
100:
    L = L + 1
    If L > 100 Then
        MsgBox "已经进行100次自乘，仍然没有获得传递性", , "无传递性"
        End
    End If
'RR=RoR
    For I = 1 To N
        For J = 1 To N
            For K = 1 To N                      '模糊矩阵元素做乘法
                If R(I, K) <= R(K, J) Then dMin(K) = R(I, K) Else dMin(K) = R(K, J)
            Next K
            dMax = dMin(1)
            For K = 1 To N                      '模糊矩阵元素做加法
                If dMin(K) >= dMax Then dMax = dMin(K)
            Next K
            RR(I, J) = dMax
        Next J
    Next I
    For I = 1 To N
        For J = 1 To N
'判断是否是模糊等价矩阵，若非则转去继续做
            If R(I, J) <> RR(I, J) Then
                For I1 = 1 To N
                    For J1 = 1 To N
                        R(I1, J1) = RR(I1, J1)
                    Next J1
                Next I1
                GoTo 100
            End If
        Next J
    Next I
End Sub