📄 main.frm
字号:
Height = 375
Index = 7
Left = 720
TabIndex = 7
Top = 4920
Width = 615
End
Begin VB.Label Label1
Caption = "0.4"
Height = 375
Index = 6
Left = 720
TabIndex = 6
Top = 4320
Width = 615
End
Begin VB.Label Label1
Caption = "0.5"
Height = 375
Index = 5
Left = 720
TabIndex = 5
Top = 3720
Width = 615
End
Begin VB.Label Label1
Caption = "0.6"
Height = 375
Index = 4
Left = 720
TabIndex = 4
Top = 3120
Width = 615
End
Begin VB.Label Label1
Caption = "0.7"
Height = 375
Index = 3
Left = 720
TabIndex = 3
Top = 2520
Width = 615
End
Begin VB.Label Label1
Caption = "0.8"
Height = 375
Index = 2
Left = 720
TabIndex = 2
Top = 1920
Width = 615
End
Begin VB.Label Label1
Caption = "0.9"
Height = 375
Index = 1
Left = 720
TabIndex = 1
Top = 1320
Width = 615
End
Begin VB.Label Label1
Caption = "1"
Height = 375
Index = 0
Left = 720
TabIndex = 0
Top = 720
Width = 615
End
End
Attribute VB_Name = "main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 1
Const tempSize = 5
Const END_QUEUE = -10000
Dim cArr() As Double '存放模糊等价矩阵
Dim copyCArr() As Double
Dim cBoolArr() As Double '聚类过程中的0-1矩阵
Dim dataArr() As Double
Dim cArrSize As Integer, dataArrRow As Integer, dataArrCol As Integer
'data val for cluster
Dim limitLine As Double, limitStep As Double, expectedLimit As Double
Dim comArr() As Double
Dim groupIndentifyArr() As Double, delegateQueue() As Double, preGroupIndentifyArr() As Double
Dim groupDelegateArr() As Double
Dim groupNum As Integer, delegateIndex As Integer
Dim totalClusterTime As Integer
Dim groupEleNum() As Integer, tmpSum As Integer, preI As Integer
Dim groupIdArr() As Integer
Dim innerIterCount As Integer
'Dim belongGroup() As Integer
'ulti datas for drawing cluster pics
Dim seqSet() As Integer, seqSet2() As Integer 'place the position in sequence of the elements
Dim seqArr() As Integer
Dim queueArr() As Integer
Dim queueIndex As Integer
Dim eachClusterNum() As Integer
Dim bucketArr() As Bucket
Dim tempBucketArr() As Bucket
Dim checkArr() As Boolean
Dim preEleNum() As Integer, curEleNum() As Integer
Dim preGroupNum As Integer
'ulti data for drawing the clustering pic
Dim setPointArr() As setPoint, setPointArr2() As setPoint
Dim x0 As Integer
Dim y0 As Integer
Dim stepX As Double
Dim stepY As Double
Dim descI As Integer
Dim Index As Integer
'other aided values
Dim tmpDotSum As Double, tmpLen As Double, tmpLen1 As Double, tmpLen2 As Double
Dim unchanged As Integer
Dim mergeVal As Double
Dim iterCount As Integer
Dim tempIndex As Integer
Dim tempVal As Double, tempInt As Integer
Private Sub cmdCluster_Click()
Dim i As Integer, j As Integer, m As Integer, k As Integer, flag As Integer, count As Integer
'Dim storeI As Integer
Dim s As Double, sum As Double, avg As Double, minVal As Double, maxVal As Double
pic.Cls
reset_form
'read in data size
readInOriginalData dataTxt.Text 'dataArr,colArrNum,rowArrNum
cArrSize = dataArrRow
ReDim cArr(cArrSize, cArrSize)
ReDim copyCArr(cArrSize, cArrSize)
ReDim cBoolArr(cArrSize, cArrSize)
'ReDim dataArr(dataArrRow, dataArrCol)
'%--normalize the read in data--%
For j = 1 To dataArrCol
sum = 0
minVal = dataArr(1, j)
maxVal = dataArr(1, j)
For i = 1 To dataArrRow
sum = sum + dataArr(i, j)
If minVal > dataArr(i, j) Then
minVal = dataArr(i, j)
ElseIf maxVal < dataArr(i, j) Then
maxVal = dataArr(i, j)
End If
Next i
avg = sum / dataArrRow
s = 0
For i = 1 To dataArrRow
s = s + (dataArr(i, j) - avg) ^ 2
Next i
s = Sqr(s / dataArrRow)
For i = 1 To dataArrRow
dataArr(i, j) = (dataArr(i, j) - avg) / s
Next i
minVal = dataArr(1, j)
maxVal = dataArr(1, j)
For i = 1 To dataArrRow
If minVal > dataArr(i, j) Then
minVal = dataArr(i, j)
ElseIf maxVal < dataArr(i, j) Then
maxVal = dataArr(i, j)
End If
Next i
For i = 1 To dataArrRow
dataArr(i, j) = (dataArr(i, j) - minVal) / (maxVal - minVal)
Next i
Next j
'%--cal dis between arr(i,j)--%
'%-----using cos method-----%
'cal with cos len method
Select Case Combo1.ListIndex
Case 0: 'cos dis
cosDis dataArrRow, dataArrCol, dataArr, cArr
Case 1: 'Euclid Dis
EuclidDis dataArrRow, dataArrCol, dataArr, cArr
Case 2: 'max-min dis
MaxminDis dataArrRow, dataArrCol, dataArr, cArr
End Select
'%--make the full c arr --%
For i = 1 To dataArrRow Step 1
For j = 1 To i - 1 Step 1
cArr(i, j) = cArr(j, i)
Next j
cArr(i, i) = 1
Next i
'%--washall enclosure algorithm--%
unchanged = 0
While unchanged = 0
unchanged = 1
'%--sigma:i=1:n(combine(conj(cArr(i,k),cArr(k,j))))
For i = 1 To cArrSize Step 1
For j = 1 To cArrSize Step 1
mergeVal = 0
For k = 1 To cArrSize Step 1
If (cArr(i, k) <= cArr(k, j) And cArr(i, k) > mergeVal) Then
mergeVal = cArr(i, k)
ElseIf (cArr(i, k) > cArr(k, j) And cArr(k, j) > mergeVal) Then
mergeVal = cArr(k, j)
End If
Next k
If (mergeVal > cArr(i, j)) Then
copyCArr(i, j) = mergeVal
unchanged = 0
Else
copyCArr(i, j) = cArr(i, j)
End If
Next j
Next i
'%--copy back--%
For i = 1 To cArrSize Step 1
For j = 1 To cArrSize Step 1
cArr(i, j) = copyCArr(i, j)
Next j
Next i
Wend
'%--cluster--%
'---init part---
limitLine = 1
limitStep = 0.01
expectedLimit = 0.1
ReDim comArr(cArrSize)
ReDim groupIndentifyArr(cArrSize)
ReDim groupDelegateArr(cArrSize)
groupNum = 1
preGroupNum = cArrSize
queueIndex = 1
iterCount = 0
totalClusterTime = 0
'---end of init part of cluster--
'prepare datas fro drawing the cluster pics
ReDim seqSet(cArrSize)
ReDim eachClusterNum(cArrSize)
ReDim queueArr(100 * (cArrSize + 1)) 'consider the worst condition
ReDim groupEleNum(100 * (cArrSize + 1))
ReDim seqArr(100 * cArrSize)
ReDim preGroupIndentifyArr(cArrSize)
ReDim groupIdArr(100 * cArrSize)
ReDim checkArr(cArrSize)
For i = 1 To cArrSize
checkArr(i) = False
preGroupIndentifyArr(i) = i
groupEleNum(i) = 1
seqArr(i) = i
groupIdArr(i) = i
Next i
'---end of preparing the datas for drawing cluster pics
'---main part of clustering--
While (limitLine >= expectedLimit)
iterCount = iterCount + 1
totalClusterTime = totalClusterTime + 1
For i = 1 To cArrSize Step 1
For j = 1 To cArrSize Step 1
If (cArr(i, j) < limitLine) Then
cBoolArr(i, j) = 0
Else
cBoolArr(i, j) = 1
End If
Next j
Next i
'%--make the comparation arr--%
For j = 1 To cArrSize Step 1
tempVal = 0
For i = 1 To cArrSize Step 1
tempVal = tempVal + cBoolArr(i, j) * 2 ^ (i - 1)
Next i
comArr(j) = tempVal
Next j
'%--core part: pation the equivalence class--%
'add these lines of code to elimate the previous iteration notes
For i = 1 To cArrSize
groupIndentifyArr(i) = -1
groupDelegateArr(i) = -1
Next i
'%--initialize part--%
groupIndentifyArr(1) = 1
groupDelegateArr(1) = 1
groupNum = 1
'%--main part of the algorithm--%
For i = 2 To cArrSize Step 1
flag = 0
For count = 1 To groupNum Step 1
If (comArr(groupDelegateArr(count)) = comArr(i)) Then
groupIndentifyArr(i) = count
flag = 1
Exit For
End If
Next count
If (flag = 0) Then
groupNum = groupNum + 1
groupDelegateArr(groupNum) = i
groupIndentifyArr(i) = groupNum
End If
Next i
ReDim eachClusterNum(groupNum)
For i = 1 To groupNum Step 1
eachClusterNum(i) = 0
Next i
'note the group id.
For i = 1 To cArrSize
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -