form1.frm

就这个 的 的 我

        For i = 1 To Cluster
            For j = 1 To DataSize
                Temp = Temp + (OldCenter(i, j) - Hcm.center(i, j)) ^ 2      ' 计算两次迭代之间的聚类中心的距离
                OldCenter(i, j) = Hcm.center(i, j)                          ' 保留上一次的聚类中心
            Next
        Next
    Loop While Hcm.Iterations < Maxiterations And Temp > MinImprovement
    Hcm.TimeUse = GetTickCount - Hcm.TimeUse
    Exit Function
ErrHandle:
    Hcm.ErrMsg = Err.Description
    Hcm.TimeUse = GetTickCount - Hcm.TimeUse
    End Function



'*************************************************************************************
'*    作    者 ：    网络
'*    函 数 名 ：    ArrayRange
'*    参    数 ：    Data     -   待测试的数据
'*    返回值 ：      返回数组的维数
'*    日    期 ：    2006-7-10 13.20.40
'*    修 改 人 ：    laviewpbt
'*    日    期 ：    2006-11-7 10。10。45
'*    版    本 ：    Version 1.2.1
'**************************************************************************************
Public Function ArrayRange(Data() As Double) As Integer
    Dim i As Integer, ret As Integer
    Dim ErrF As Boolean
    ErrF = False
    On Error GoTo ErrHandle
    For i = 1 To 60               'VB中数组最大为60
        ret = UBound(mArray, i)   '用UBound函数判断某一维的上界，如果大数组的实际维数时产生超出范围错误，此时我们通过Resume Next 来捕捉错这个错误
        ret = ret + 1
        If ErrF Then Exit For
    Next
    ArrayRange = ret
    Exit Function
ErrHandle:
    ret = i
    ErrF = True
    Resume Next
End Function








Private Sub Average_Linkage(ByRef Data() As Double, Cluster As Byte)
    Dim DataNumber As Long, DataSize As Long
    DataNumber = UBound(Data, 1): DataSize = UBound(Data, 2)
    Dim i As Long, j As Long, ClassNumber As Long
    Dim Distance() As Double, Sum As Long
    Dim Temp1 As Double, Temp2 As Double, Min As Double, Dist As Double
    Dim center() As Double
 
    ClassNumber = DataNumber
    Dim Degree() As Long
    ReDim Degree(1 To DataNumber)
    For i = 1 To DataNumber
        Degree(i) = i
    Next

    Do
    Min = 100000000000#
    ReDim center(1 To ClassNumber, 1 To DataSize) As Double
    ReDim Distance(1 To 0.5 * ClassNumber * ClassNumber - 0.5 * ClassNumber)

    For i = 1 To ClassNumber
        Sum = 0
        For j = 1 To DataNumber
            If Degree(j) = i Then
                For k = 1 To DataSize
                    center(i, k) = center(i, k) + Data(j, k)
                Next
                Sum = Sum + 1
            End If
        Next
        If Sum <> 0 Then
        For k = 1 To DataSize
            center(i, k) = center(i, k) / Sum
        Next
        End If
    Next
    Sum = 0
    For i = 1 To ClassNumber
        For j = i + 1 To ClassNumber
            Sum = Sum + 1
            For k = 1 To DataSize
                Temp1 = center(i, k) - center(j, k)
                Distance(Sum) = Distance(Sum) + Temp1 * Temp1
            Next
            If Min > Distance(Sum) Then
                Min = Distance(Sum)
            End If
        Next
    Next
    Dim t As Long
    t = ClassNumber
    For i = 1 To ClassNumber - 1
        For j = i + 1 To ClassNumber
            Dist = 0
            For k = 1 To DataSize
                Temp1 = center(i, k) - center(j, k)
                Dist = Dist + Temp1 * Temp1
            Next
            If Dist = Min Then
                Degree(j) = i
                t = t - 1
            End If
        Next
    Next
    ClassNumber = t
Debug.Print ClassNumber
Debug.Print
     Loop While ClassNumber > Text1.Text
     Dim TempStr As String
Sum = 0
Dim choice() As Long
ReDim choice(1 To ClassNumber)

choice(1) = Degree(1)
For i = 2 To DataNumber
    For j = 1 To ClassNumber
        If choice(j) = 0 Then
            choice(j) = Degree(i)
            Exit For
        End If
    Next
    If choice(ClassNumber) <> 0 Then
        Exit For
    End If
Next

For i = 1 To DataNumber
    For j = 1 To ClassNumber
        If Degree(i) = choice(j) Then
            Degree(i) = j
            Exit For
        End If
    Next
Next
      


    For i = 1 To DataNumber
        DrawMark Picture1(1), CSng(Data(i, 1)), CSng(Data(i, 2)), CInt(Degree(i)), vbRed
    Next

End Sub





Private Sub DrawMark(Pic As PictureBox, X As Single, Y As Single, mType As Byte, Color As OLE_COLOR)
    Select Case mType
    Case 1
        Pic.Line (X - 2, Y + 2)-(X + 3, Y - 3), Color
        Pic.Line (X - 2, Y - 2)-(X + 3, Y + 3), Color
    Case 2
        Pic.Circle (X, Y), 2, Color
    Case 3
        Pic.Line (X - 2, Y - 2)-(X + 2, Y + 2), Color, B
    Case 4
        Pic.Line (X, Y - 2)-(X, Y + 3), Color
        Pic.Line (X - 2, Y)-(X + 3, Y), Color
    Case 5
        Pic.Line (X - 2, Y - 2)-(X, Y), Color
        Pic.Line (X, Y)-(X + 2, Y - 5), Color
    Case 6
        Pic.Circle (X, Y), 2, Color
        Pic.Line (X, Y - 2)-(X, Y + 2), Color
        Pic.Line (X - 2, Y)-(X + 2, Y), Color
    End Select
End Sub

    



Private Sub CmdClear_Click()
    Dim i As Integer
    For i = 0 To 8
        Picture1(i).Cls
    Next
    ReDim Data(1 To 400, 1 To 2)
    Erase NewData
    PointNumber = 0
    Option1(0).Value = True
End Sub

Private Sub CmdFcm_Click()
    If Option1(1).Value = False Then Option1(1).Value = True
    Dim IniCenter As IniCenterMethod
    Dim AntiFuzzy As AntiFuzzyMethod
    Dim i As Integer
    If OptCenter(0).Value Then
        IniCenter = CreateRandom
    ElseIf OptCenter(1) Then
        IniCenter = CreateByRandomZadeh
    Else
        IniCenter = CreateByHcm
    End If
    
    If OptAntiFuzzy(0).Value Then
        AntiFuzzy = CreateRandom
    ElseIf OptAntiFuzzy(1) Then
        AntiFuzzy = CreateByRandomZadeh
    Else
        AntiFuzzy = CreateByHcm
    End If
    Dim F As FcmInfo
    F = Fcm(NewData, Val(Text1.Text), IniCenter, AntiFuzzy)
    Index = Index + 1
    If Index > 8 Then Index = 2
    Picture1(Index).Cls

    For i = 1 To UBound(NewData)
        DrawMark Picture1(Index), CSng(NewData(i, 1)), CSng(NewData(i, 2)), F.Class(i), vbRed
    Next
    
    For i = 1 To Val(Text1.Text)
        DrawMark Picture1(Index), CSng(F.center(i, 1)), CSng(F.center(i, 2)), CByte(i), vbBlue
    Next
    
End Sub

Private Sub CmdHcm_Click()
    If Option1(1).Value = False Then Option1(1).Value = True
    On Error Resume Next
    Dim i As Integer, j As Integer
    Dim H As HcmInfo
    j = Text1.Text
    H = Hcm(NewData, j)
    Picture1(1).Cls
    For i = 1 To UBound(NewData)
        DrawMark Picture1(1), CSng(NewData(i, 1)), CSng(NewData(i, 2)), H.Class(i), vbRed
    Next
    For i = 1 To j
        DrawMark Picture1(1), CSng(H.center(i, 1)), CSng(H.center(i, 2)), CInt(i), vbBlue
    Next

End Sub

Private Sub CmdRnd_Click()
    Dim i As Integer
    Dim Width As Integer, Height As Integer
    Width = Picture1(0).Width - 20: Height = Picture1(0).Height - 20
    CmdClear_Click
    Randomize
    Option1(0).Value = True
    For i = 1 To HScroll1.Value
        Call Picture1_MouseDown(0, 1, 1, Rnd * Width + 10, Rnd * Height + 10)
    Next
End Sub










Private Sub Command6_Click()
    Option1(1).Value = True
    Average_Linkage NewData, 3
End Sub

Private Sub Form_Load()
    ReDim Data(1 To 400, 1 To 2)
    Index = 1
End Sub




Private Sub Option1_Click(Index As Integer)
   If Index = 0 Then
        Call CmdClear_Click
    Else
        If PointNumber <> 0 Then
            ReDim NewData(1 To PointNumber, 1 To 2)
            For i = 1 To PointNumber
                NewData(i, 1) = Data(i, 1)
                NewData(i, 2) = Data(i, 2)
            Next
            PointNumber = 0
        End If
    End If
End Sub

Private Sub Picture1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Option1(0).Value = True Then
        If Index = 0 Then
            DrawMark Picture1(0), X, Y, 4, vbRed
        End If
        PointNumber = PointNumber + 1
        Data(PointNumber, 1) = X
        Data(PointNumber, 2) = Y
    End If

End Sub