fun.bas

用vb实现的C均值聚类分析

Attribute VB_Name = "disFun"
Public Function cosDis(dataArrRow As Integer, dataArrCol As Integer, dataArr() As Double, cArr() As Double)
    Dim i As Integer, j As Integer, m As Integer
    Dim tmpDotSum As Double, tmpLen As Double, tmpLen1 As Double, tmpLen2 As Double
    
    For i = 1 To dataArrRow Step 1
        For j = i + 1 To dataArrRow Step 1
            tmpDotSum = 0
            tmpLen = 0
            tmpLen1 = 0
            tmpLen2 = 0
            For m = 1 To dataArrCol Step 1
                tmpDotSum = tmpDotSum + dataArr(i, m) * dataArr(j, m)
                tmpLen1 = tmpLen1 + dataArr(i, m) ^ 2
                tmpLen2 = tmpLen2 + dataArr(j, m) ^ 2
            Next m
            tmpLen = Sqr(tmpLen1) * Sqr(tmpLen2)
            cArr(i, j) = tmpDotSum / tmpLen
        Next j
    Next i

End Function

Public Function EuclidDis(dataArrRow As Integer, dataArrCol As Integer, dataArr() As Double, cArr() As Double)
    Dim i As Integer, j As Integer, m As Integer
    Dim tmpSum As Double
    
    For i = 1 To dataArrRow Step 1
        For j = i + 1 To dataArrRow Step 1
            tmpSum = 0
            For m = 1 To dataArrCol Step 1
                tmpSum = tmpSum + (dataArr(i, m) - dataArr(j, m)) ^ 2
            Next m
            
            cArr(i, j) = Sqr(tmpSum / dataArrCol)
        Next j
    Next i
End Function
 
 Public Function MaxminDis(dataArrRow As Integer, dataArrCol As Integer, dataArr() As Double, cArr() As Double)
    Dim i As Integer, j As Integer, m As Integer
    Dim tmpMinSum As Double, tmpMaxSum As Double
    
    For i = 1 To dataArrRow Step 1
        For j = i + 1 To dataArrRow Step 1
            tmpMinSum = 0
            tmpMaxSum = 0
            For m = 1 To dataArrCol Step 1
                If dataArr(i, m) <= dataArr(j, m) Then
                    tmpMinSum = tmpMinSum + dataArr(i, m)
                    tmpMaxSum = tmpMaxSum + dataArr(j, m)
                Else
                    tmpMinSum = tmpMinSum + dataArr(j, m)
                    tmpMaxSum = tmpMaxSum + dataArr(i, m)
                End If
            Next m
            cArr(i, j) = tmpMinSum / tmpMaxSum
        Next j
    Next i
End Function