?? 模糊聚類m3.bas

?? 模糊數(shù)學(xué)中模糊聚類算法的vb實現(xiàn)
?? BAS
字號:
Attribute VB_Name = "modMethod"
'模糊聚類分析
'標(biāo)定方法、傳遞閉包法、相似性檢查
Option Explicit
'數(shù)量積法
'X(1 To N,1 To M)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
'dbM為用戶提供的M參數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To M)：相似矩陣，N為樣本數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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
    
'相關(guān)分析法
'X(1 To N,1 To M)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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

'指數(shù)相似系數(shù)法
'X(1 To N,1 To M)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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

'算術(shù)平均值最小法
'X(1 To N,1 To M)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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

'絕對值倒數(shù)法
'X(1 To N,1 To M)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
'dbM為用戶提供的M參數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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

'絕對值指數(shù)法
'X(1 To N,1 To M)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
'dbC：用戶提供的C參數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
'dbC：用戶提供的C參數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
'dbC：用戶提供的C參數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
    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
   
'海明加權(quán)，僅適用于特例
'X(1 To N,1 To M)：觀測數(shù)據(jù)，N為樣本數(shù)，M為指標(biāo)數(shù)
'R(1 To N,1 To N)：相似矩陣，N為樣本數(shù)
'dbC：用戶提供的C參數(shù)
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:樣品數(shù)；M:指標(biāo)數(shù)
'*****************************************************************************
    For I = 1 To M                              'cc是權(quán)
        cc(I) = ((M + 1) - I) / 10              '這里的權(quán)僅對特例有效
    Next I                                      '如果遇到其他加權(quán)形式需進行修改
'*****************************************************************************
    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為樣本數(shù)
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 "行數(shù)和列數(shù)不等", , "相似矩陣錯誤"
        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為樣本數(shù)
'rr(1 To N,1 To N)：模糊乘積矩陣，N為樣本數(shù)
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:樣品數(shù)
    L = 0
100:
    L = L + 1
    If L > 100 Then
        MsgBox "已經(jīng)進行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
'判斷是否是模糊等價矩陣，若非則轉(zhuǎn)去繼續(xù)做
            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
?? 文件大小 46 K
?? 上傳用戶 linux_open_lab
?? 所屬分類人工智能/神經(jīng)網(wǎng)絡(luò)
??? 相關(guān)標(biāo)簽

#模糊數(shù)學(xué) #模糊聚類 #算法
?? 快捷鍵說明

復(fù)制代碼 Ctrl + C
搜索代碼 Ctrl + F
全屏模式 F11
切換主題 Ctrl + Shift + D
顯示快捷鍵 ?
增大字號 Ctrl + =
減小字號 Ctrl + -
亚洲欧美第一页_禁久久精品乱码_粉嫩av一区二区三区免费野_久草精品视频

?? 模糊聚類m3.bas

?? 快捷鍵說明
