?? 點群分析f2.frm
字號:
VERSION 5.00
Begin VB.Form frmCalculate
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "點群分析"
ClientHeight = 10590
ClientLeft = 60
ClientTop = 345
ClientWidth = 7560
LinkTopic = "Form1"
ScaleHeight = 10590
ScaleWidth = 7560
Begin VB.CommandButton cmdContinue
Caption = "繼 續"
BeginProperty Font
Name = "黑體"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 6720
TabIndex = 2
Top = 720
Width = 855
End
Begin VB.CommandButton cmdExit
Caption = "結 束"
BeginProperty Font
Name = "黑體"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 6720
TabIndex = 1
Top = 360
Width = 855
End
Begin VB.CommandButton cmdCalculate
Caption = "計 算"
BeginProperty Font
Name = "黑體"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 6720
TabIndex = 0
Top = 0
Width = 855
End
End
Attribute VB_Name = "frmCalculate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'點群分析
Option Explicit
Dim intR As Integer
Private Sub Form_Load()
cmdContinue.Visible = False
End Sub
'計算
Private Sub cmdCalculate_Click()
On Error Resume Next
For I = 1 To N
KK(I) = 1
Next I
If Key = 1 Then YS = -100000000000# '距離系數為統計量
If Key = 2 Then '夾角余弦為統計量
YS = 100000000000#
For I = 1 To N
For J = 1 To M
Xc(I) = Xc(I) + X(I, J) ^ 2 '求數據行的平方和
Next J
Next I
End If
If Key > 2 Then '相關系數為統計量
YS = 100000000000#
For I = 1 To N
For J = 1 To M
Xa(I) = Xa(I) + X(I, J)
Next J
Xa(I) = Xa(I) / M '平均值
For J = 1 To M '求離差平方和
Xc(I) = Xc(I) + (X(I, J) - Xa(I)) ^ 2
Next J
Next I
End If
'M1為譜系圖中垂向連線數；M2為譜系圖的水平連線數；M3為譜系圖的顯示掃描行數
M1 = N - 1: M2 = N * 2 - 2: M3 = N * 2 - 1
For L = 1 To M1
L1 = 0: L2 = 0: L3 = 0: L4 = 0: L5 = (L - 1) * 2
N1 = 0: N2 = 0
If Key = 1 Then YM = 100000000000#
If Key <> 1 Then YM = -100000000000#
'計算分類統計量，只需計算下三角部分
For I = 2 To N
If KK(I) = 0 Then GoTo 31
I1 = I - 1
For J = 1 To I1
If KK(J) = 0 Then GoTo 30
S1 = 0
If Key = 1 Then '以距離系數為統計量
For K = 1 To M
S1 = S1 + (X(J, K) - X(I, K)) ^ 2
Next K
S = Sqr(S1)
If S < YM Then
YM = S: LI = I: LJ = J
End If
End If
If Key = 2 Then '以夾角余弦為統計量
For K = 1 To M
S1 = S1 + X(J, K) * X(I, K)
Next K
S2 = Sqr(Xc(J) * Xc(I))
S = S1 / S2
If S > YM Then
YM = S: LI = I: LJ = J
End If
End If
If Key > 2 Then '以相關系數為統計量
For K = 1 To M
S1 = S1 + (X(J, K) - Xa(J)) * (X(I, K) - Xa(I))
Next K
S2 = Sqr(Xc(J) * Xc(I))
S = S1 / S2
If S > YM Then
YM = S: LI = I: LJ = J
End If
End If
30: Next J
31: Next I
'YM1為第一次并類時的分類統計量（L=1）
'YM2為最后次并類時的分類統計量（L=M1）
'為后面計算譜系圖的刻度尺作準備
If L = 1 Then YM1 = YM
If L = M1 Then YM2 = YM
If Key = 1 Then _
Me.Print " 第"; L; "次", "合并類："; LI; "-"; LJ, "距離系數："; YM
If Key = 2 Then _
Me.Print " 第"; L; "次", "合并類："; LI; "-"; LJ, "夾角余弦："; YM
If Key > 2 Then _
Me.Print " 第"; L; "次", "合并類："; LI; "-"; LJ, "相關系數："; YM
'按加權平均法求合并后的新群的各個變量值（或樣本值）
'KK為合并類中所包括的樣本數（或變量數）
For J = 1 To M
X(LJ, J) = (X(LJ, J) * KK(LJ) + X(LI, J) * KK(LI)) / (KK(LI) + KK(LJ))
Next J
'根據統計量，為計算“新類”與“原有類”之間的分類統計量作準備
If Key = 2 Then '準備計算相似系數
Xc(LJ) = 0
For J = 1 To M
Xc(LJ) = Xc(LJ) + X(LJ, J) ^ 2
Next J
End If
If Key > 2 Then '準備計算相關系數
Xa(LJ) = 0
For J = 1 To M
Xa(LJ) = Xa(LJ) + X(LJ, J)
Next J
Xa(LJ) = Xa(LJ) / M
Xc(LJ) = 0
For J = 1 To M
Xc(LJ) = Xc(LJ) + (X(LJ, J) - Xa(LJ)) ^ 2
Next J
End If
'完成一次并類后，計算譜系圖中各種連線的坐標，根據LI、LJ兩者
'之間的關系，可以按7種情況分別計算處理
For K = 1 To N
If KM(K) = LI Then GoTo 41
If KM(K) = LJ Then GoTo 60
If KM(K) = 0 Then GoTo 40
Next K
40: '（1）。當LI,LJ均未出現
KM(K) = LI
KM(K + 1) = LJ
KX1(L * 2 - 1) = (K - 1) * 2 + 1
X1(L * 2 - 1) = YM1
KX1(L * 2) = (K - 1) * 2 + 3
X1(L * 2) = YM1
GoTo 77
41: '（2）。當LI類已出現，而LJ類未出現
For J = K To N
If KM(J) = LJ Then GoTo 49
If KM(J) = 0 Then GoTo 43
Next J
43: L1 = K + 1
L2 = J - 1
If L2 < L1 Then GoTo 48
For J = L1 To L2
KN(J) = KM(J)
Next J
For J = L1 To L2
KM(J + 1) = KN(J)
Next J
For J = 1 To L5
If KX1(J) >= L1 * 2 - 1 Then KX1(J) = KX1(J) + 2
Next J
For J = 1 To N
If KLJ(J) >= L1 * 2 - 1 Then KLJ(J) = KLJ(J) + 2
Next J
48: '（3）。當LI類已出現，LJ類未出現，
'LI類后面沒有其他類時
KM(L1) = LJ
KX1(L * 2 - 1) = KLJ(LI)
X1(L * 2 - 1) = XLJ(LI)
KX1(L * 2) = L1 * 2 - 1
X1(L * 2) = YM1
GoTo 77
49: '（4）。當LI類先出現，LJ類后出現，
'LI類與LJ類相鄰
If J - K <> KK(LJ) Then GoTo 50
KX1(L * 2 - 1) = KLJ(LI)
X1(L * 2 - 1) = XLJ(LI)
KX1(L * 2) = KLJ(LJ)
X1(L * 2) = XLJ(LJ)
GoTo 77
50: '（5）。當LI類先出現，LJ類后出現，
'LI類與LJ類不相鄰
L1 = K + 1
L2 = J - KK(LJ)
L3 = L2 + 1
L4 = J
For J = L1 To L4
KN(J) = KM(J)
Next J
N1 = KK(LJ)
For J = L1 To L2
KM(J + N1) = KN(J)
Next J
N2 = L4 - K - N1
For J = L3 To L4
KM(J - N2) = KN(J)
Next J
For J = 1 To L5
If KX1(J) >= L1 * 2 - 1 And KX1(J) <= L2 * 2 - 1 Then GoTo 54
If KX1(J) >= L3 * 2 - 1 And KX1(J) <= L4 * 2 - 1 Then GoTo 55
GoTo 56
54: KX1(J) = KX1(J) + N1 * 2
GoTo 56
55: KX1(J) = KX1(J) - N2 * 2
56: Next J
For J = 1 To N
If KLJ(J) >= L1 * 2 - 1 And KLJ(J) <= L2 * 2 - 1 Then GoTo 57
If KLJ(J) >= L3 * 2 - 1 And KLJ(J) <= L4 * 2 - 1 Then GoTo 58
GoTo 59
57: KLJ(J) = KLJ(J) + N1 * 2
GoTo 59
58: KLJ(J) = KLJ(J) - N2 * 2
59: Next J
KX1(L * 2 - 1) = KLJ(LI)
X1(L * 2 - 1) = XLJ(LI)
KX1(L * 2) = KLJ(LJ)
X1(L * 2) = XLJ(LJ)
GoTo 77
60: '（6）。當LJ類出現，而LI類未出現
For J = K To N
If KM(J) = LI Then GoTo 67
If KM(J) = 0 Then GoTo 62
Next J
62: L1 = K - KK(LJ) + 1
L2 = J - 1
For J = L1 To L2
KN(J) = KM(J)
Next J
For J = L1 To L2
KM(J + 1) = KN(J)
Next J
KM(L1) = LI
For J = 1 To L5
If KX1(J) >= L1 * 2 - 1 Then KX1(J) = KX1(J) + 2
Next J
For J = 1 To N
If KLJ(J) >= L1 * 2 - 1 Then KLJ(J) = KLJ(J) + 2
Next J
KX1(L * 2 - 1) = L1 * 2 - 1
X1(L * 2 - 1) = YM1
KX1(L * 2) = KLJ(LJ)
X1(L * 2) = XLJ(LJ)
GoTo 77
67: '（7）。當LJ類先出現，LI類后出現
L1 = K - KK(LJ) + 1
L2 = J - KK(LI)
L3 = L2 + 1
L4 = J
For J = L1 To L4
KN(J) = KM(J)
Next J
N1 = KK(LI)
For J = L1 To L2
KM(J + N1) = KN(J)
Next J
N2 = L3 - L1
For J = L3 To L4
KM(J - N2) = KN(J)
Next J
For J = 1 To L5
If KX1(J) >= L1 * 2 - 1 And KX1(J) <= L2 * 2 - 1 Then GoTo 71
If KX1(J) >= L3 * 2 - 1 And KX1(J) <= L4 * 2 - 1 Then GoTo 72
GoTo 73
71: KX1(J) = KX1(J) + N1 * 2
GoTo 73
72: KX1(J) = KX1(J) - N2 * 2
73: Next J
For J = 1 To N
If KLJ(J) >= L1 * 2 - 1 And KLJ(J) <= L2 * 2 - 1 Then GoTo 74
If KLJ(J) >= L3 * 2 - 1 And KLJ(J) <= L4 * 2 - 1 Then GoTo 75
GoTo 76
74: KLJ(J) = KLJ(J) + N1 * 2
GoTo 76
75: KLJ(J) = KLJ(J) - N2 * 2
76: Next J
KX1(L * 2 - 1) = KLJ(LI)
X1(L * 2 - 1) = XLJ(LI)
KX1(L * 2) = KLJ(LJ)
X1(L * 2) = XLJ(LJ)
'根據上面的計算結果，繼續計算譜系圖中各種連線的坐標
77: KX2(L * 2 - 1) = KX1(L * 2) - KX1(L * 2 - 1) - 1
KX2(L * 2) = 0
X2(L * 2 - 1) = YM
X2(L * 2) = YM
KLJ(LJ) = (KX1(L * 2) + KX1(L * 2 - 1)) / 2
XLJ(LJ) = YM
KK(LJ) = KK(LJ) + KK(LI)
KK(LI) = 0
YS = YM
Next L
intR = MsgBox("是否顯示譜系圖數據？", vbYesNo)
If intR = vbYes Then
Me.Cls
Me.Print "垂向連線總數："; M1, "水平連線總數："; M2, "掃描行數："; M3
Me.Print "水平連線號", "左端橫坐標", "右端橫坐標", "行位", "延續行數"
For I = 1 To M2
X1(I) = Int(X1(I) * 1000 + 0.5) / 1000 '按四舍五入取3位有效數字
X2(I) = Int(X2(I) * 1000 + 0.5) / 1000 '按四舍五入取3位有效數字
Me.Print I, X1(I), X2(I), KX1(I), KX2(I)
Next I
End If
cmdContinue.Visible = True
End Sub
'繼續
Private Sub cmdContinue_Click()
Unload Me
frmContinue.Visible = True
End Sub
'結束
Private Sub cmdExit_Click()
Unload Me
End
End Sub
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -