📄 form1.frm
字号:
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'程序实现功能：模糊聚类和硬聚类
'作 者： laviewpbt
'联系方式： laviewpbt@sina.com
'QQ:33184777
'版本：Version 2.3.1
'说明：复制请保留源作者信息，转载请说明，欢迎大家提出意见和建议
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Enum IniCenterMethod '初始中心的方法
CreateRandom '随机的中心点
CreateByHcm '由HCM创建的中心点
CreateByRandomZadeh '先随机创建隶属矩阵，然后计算得到的中心点
CreateByHand '手工确定初始中心点
End Enum
Private Enum AntiFuzzyMethod '反模糊的方法
Max '最大隶属度法
Middle '中位数法
Mean '加权平均值法
End Enum
Private Type FcmInfo
center() As Double '聚类中心
Degree() As Double '隶属度，为Double类型
Class() As Byte '记录数据属于那一类
TimeUse As Long '所用时间
Iterations As Long '迭带次数
ErrMsg As String '错误信息
End Type
Private Type HcmInfo
center() As Double '聚类中心
Class() As Byte '记录数据属于那一类
TimeUse As Long '所用时间
Iterations As Long '迭带次数
ErrMsg As String '错误信息
End Type
Dim Data() As Double
Dim NewData() As Double
Dim PointNumber As Integer
Dim Index As Integer
'*************************************************************************************
'* 作 者 ： laviewpbt
'* 函 数 名 ： Fcm
'* 参 数 ： Data - 待分类的样本，第一维的大小表示样本的个数，
'* 第二维的大小表示样本的维数
'* Cluster - 分类数
'* CreateIniCenter - 初始聚类中心的创建方法
'* AntiFuzzy - 反模糊化的方法
'* Exponent - 一个控制聚类效果的参数，一般取2
'* Maxiterations - 最大的迭代次数
'* MinImprovement - 最小的改进参数（两次迭代间聚类中心的距离）
'* 返回值 ： FcmInfo结构，记录了相关的参数
'* 功能描述 ： 利用模糊理论的聚类方法把数据分类
'* 日 期 ： 2004-10-27 10.25.32
'* 修 改 人 ： laviewpbt
'* 日 期 ： 2006-11-7 19.25.31
'* 版 本 ： Version 2.3.1
'**************************************************************************************
Private Function Fcm(ByRef Data() As Double, ByVal Cluster As Long, Optional ByVal CreateIniCenter As IniCenterMethod = IniCenterMethod.CreateByHcm, Optional AntiFuzzy As AntiFuzzyMethod = Max, Optional Exponent As Byte = 2, Optional Maxiterations As Long = 400, Optional MinImprovement As Double = 0.01, Optional ByRef CenterByHandle As Variant) As FcmInfo
If ArrayRange(Data) <> 2 Then
Fcm.ErrMsg = "数据只能为二维数组"
Exit Function
End If
Dim i As Long, j As Long, k As Long, l As Long, m As Long
Dim DataNumber As Long, DataSize As Long
Dim Temp As Double, Sum1 As Double, Sum2 As Double, Sum3 As Double, Index As Integer
Dim OldCenter() As Double
Fcm.TimeUse = GetTickCount
DataNumber = UBound(Data, 1): DataSize = UBound(Data, 2)
ReDim Fcm.center(1 To Cluster, 1 To DataSize) As Double
ReDim Fcm.Degree(1 To Cluster, 1 To DataNumber) As Double
ReDim Fcm.Class(1 To DataNumber) As Byte
ReDim OldCenter(1 To Cluster, 1 To DataSize) As Double
On Error GoTo ErrHandle:
Randomize
If CreateIniCenter = CreateRandom Then
For i = 1 To Cluster
For j = 1 To DataSize
OldCenter(i, j) = Data(Rnd * DataNumber, j) '产生随机初始中心点
Next
Next
ElseIf CreateIniCenter = CreateByHcm Then
Dim HcmCenter As HcmInfo
HcmCenter = Hcm(Data, Cluster)
For i = 1 To Cluster
For j = 1 To DataSize
OldCenter(i, j) = HcmCenter.center(i, j) '产生HCM初始中心点
Next
Next
ElseIf CreateIniCenter = CreateByRandomZadeh Then
ReDim RndDegree(1 To Cluster, 1 To DataNumber) As Double
Dim RndSum As Double
For i = 1 To Cluster
For j = 1 To DataNumber
RndDegree(i, j) = Rnd '创建随机的隶属度
Next
Next
For j = 1 To DataNumber
RndSum = 0
For i = 1 To Cluster
RndSum = RndSum + RndDegree(i, j)
Next
For i = 1 To Cluster
RndDegree(i, j) = RndDegree(i, j) / RndSum '隶属度矩阵每列之后必须为1
Next
Next
For i = 1 To Cluster
For j = 1 To DataSize
Sum1 = 0: Sum2 = 0
For k = 1 To DataNumber
Temp = Exp(Log(RndDegree(i, k)) * Exponent) '其实就是RndDegree(i, k)^Exponent
Sum1 = Sum1 + Temp * Data(k, j) '隶属度的平方乘以数值
Sum2 = Sum2 + Temp '隶属度的和
Next
OldCenter(i, j) = Sum1 / Sum2 '得到聚类中心
Next
Next
ElseIf CreateIniCenter = CreateByHand Then
If IsMissing(CenterByHandle) Then
Fcm.ErrMsg = "请提供初始聚类中心。."
Exit Function
ElseIf UBound(CenterByHandle, 1) <> Cluster Or UBound(CenterByHandle, 2) <> DataSize Then
Fcm.ErrMsg = "手工提供的初始聚类中心维数有错误."
Exit Function
End If
For i = 1 To Cluster
For j = 1 To DataSize
OldCenter(i, j) = CenterByHandle(i, j)
Next
Next
End If
Do
Fcm.Iterations = Fcm.Iterations + 1
For i = 1 To Cluster
For j = 1 To DataNumber
Sum1 = 0: Sum3 = 1
For k = 1 To DataSize
Temp = Data(j, k) - OldCenter(i, k)
Sum1 = Sum1 + Temp * Temp '计算第j点到第i个聚类中心的距离
Next
If Sum1 = 0 Then
Fcm.Degree(i, j) = 1 '如果j点与第i个聚类中心重合，则完全属于该类
Else
For k = 1 To Cluster
Sum2 = 0
If k <> i Then
For l = 1 To DataSize
Temp = Data(j, l) - OldCenter(k, l)
Sum2 = Sum2 + Temp * Temp '计算第j点到其他聚类中心的距离
Next
Sum3 = Sum3 + Exp(Log(Sum1 / Sum2) * (2 / (Exponent - 1))) '计算累加值,
End If
Next
Fcm.Degree(i, j) = 1 / Sum3 '计算新的隶属度
End If
Next
Next
For i = 1 To Cluster
For j = 1 To DataSize
Sum1 = 0: Sum2 = 0
For k = 1 To DataNumber
Temp = Exp(Log(Fcm.Degree(i, k)) * Exponent)
Sum1 = Sum1 + Temp * Data(k, j) '隶属度的平方乘以数值
Sum2 = Sum2 + Temp '隶属度的和
Next
Fcm.center(i, j) = Sum1 / Sum2 '得到新的聚类中心
Next
Next
Temp = 0
For i = 1 To Cluster
For j = 1 To DataSize
Temp = Temp + (OldCenter(i, j) - Fcm.center(i, j)) ^ 2 ' 计算两次迭代之间的聚类中心的距离
OldCenter(i, j) = Fcm.center(i, j) ' 保留上一次的聚类中心
Next
Next
Loop While Fcm.Iterations < Maxiterations And Temp > MinImprovement
If AntiFuzzy = Max Then
For i = 1 To DataNumber
Temp = -1
For k = 1 To Cluster
If Temp < Fcm.Degree(k, i) Then '得到列方向的最大值
Temp = Fcm.Degree(k, i)
Index = k
End If
Next
Fcm.Class(i) = Index 'Index记录了列方向最大隶属度的类
Next
ElseIf AntiFuzzy = Mean Then
For i = 1 To DataNumber
Temp = 0
For j = 1 To Cluster
Temp = Temp + Fcm.Degree(j, i) * j '去隶书乘以对应的类别数之和
Next
Fcm.Class(i) = CInt(Temp)
Next
ElseIf AntiFuzzy = Middle Then
For i = 1 To DataNumber
Temp = 0
For j = 1 To Cluster
If Temp <= 0.5 And Temp + Fcm.Degree(j, i) >= 0.5 Then
Index = j
Exit For
Else
Temp = Temp + Fcm.Degree(j, i) '取面积的一半处
End If
Next
Fcm.Class(i) = Index
Next
End If
Fcm.TimeUse = GetTickCount - Fcm.TimeUse
Exit Function
ErrHandle:
Fcm.ErrMsg = Err.Description
Fcm.TimeUse = GetTickCount - Fcm.TimeUse
End Function
'*************************************************************************************
'* 作 者 ： laviewpbt
'* 函 数 名 ： Hcm
'* 参 数 ： Data - 待分类的样本，第一维的大小表示样本的个数，
'* 第二维的大小表示样本的维数
'* Cluster - 分类数
'* Maxiterations - 最大的迭代次数
' MinImprovement - 最小的改进参数（两次迭代间聚类中心的距离）
'* 返回值 ： HcmInfo结构，记录了相关的参数
'* 功能描述 ： 直接利用硬聚类方法把数据分类
'* 日 期 ： 2004-10-24 20.10.56
'* 修 改 人 ： laviewpbt
'* 日 期 ： 2006-11-7 20.11.23
'* 版 本 ： Version 2.3.1
'**************************************************************************************
Private Function Hcm(ByRef Data() As Double, ByVal Cluster As Byte, Optional Maxiterations As Long = 400, Optional MinImprovement As Double = 0.01) As HcmInfo
If ArrayRange(Data) <> 2 Then
Hcm.ErrMsg = "数据只能为二维数组"
Exit Function
End If
Dim i As Long, j As Long, k As Long, l As Long, m As Long
Dim DataNumber As Long, DataSize As Long
Dim Temp As Double, DX As Double, DY As Double, SumValue() As Double, SumNumber() As Long
Dim OldCenter() As Double, Distance As Double, Dist As Double, Index As Long
On Error GoTo ErrHandle:
Hcm.TimeUse = GetTickCount
DataNumber = UBound(Data, 1): DataSize = UBound(Data, 2)
ReDim Hcm.center(1 To Cluster, 1 To DataSize) As Double
ReDim Hcm.Class(1 To DataNumber) As Byte
ReDim OldCenter(1 To Cluster, 1 To DataSize) As Double
For i = 1 To Cluster
For j = 1 To DataSize
OldCenter(i, j) = Data(i * DataNumber / Cluster, j) '产生初始中心点
Next
Next
Do
Hcm.Iterations = Hcm.Iterations + 1
ReDim SumNumber(Cluster) As Long
ReDim SumValue(Cluster, DataSize) As Double
For i = 1 To DataNumber
Distance = 40000000000#
For j = 1 To Cluster
Dist = 0
For k = 1 To DataSize
Temp = Data(i, k) - OldCenter(j, k)
Dist = Dist + Temp * Temp '计算第j点到第i个聚类中心的距离
Next
If Distance > Dist Then
Distance = Dist
Index = j '把i点归于距离该点最近的中心点所在的类
End If
Next
Hcm.Class(i) = Index
For j = 1 To DataSize
SumValue(Index, j) = SumValue(Index, j) + Data(i, j)
Next
SumNumber(Index) = SumNumber(Index) + 1
Next
For i = 1 To Cluster
For k = 1 To DataSize
If SumNumber(i) = 0 Then
Hcm.center(i, k) = Data(Rnd * DataNumber, k)
Else
Hcm.center(i, k) = SumValue(i, k) / SumNumber(i) '求新的中心
End If
Next
Next
Temp = 0
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -