📄 点群分析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 + -