📄 form04.frm
字号:
VERSION 5.00
Begin VB.Form Form04
BackColor = &H80000013&
Caption = "逐步判别分析"
ClientHeight = 6255
ClientLeft = 60
ClientTop = 465
ClientWidth = 10485
Icon = "Form04.frx":0000
LinkTopic = "Form1"
ScaleHeight = 6255
ScaleWidth = 10485
StartUpPosition = 3 '窗口缺省
Begin VB.Frame Frame2
BackColor = &H80000013&
Caption = "分析结果"
Height = 6255
Left = 3600
TabIndex = 5
Top = 0
Width = 6735
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
BackColor = &H80000013&
Height = 5895
Left = 120
ScaleHeight = 5835
ScaleWidth = 6435
TabIndex = 6
Top = 240
Width = 6495
End
End
Begin VB.Frame Frame1
BackColor = &H80000013&
Caption = "数据矩阵"
Height = 3495
Left = 120
TabIndex = 3
Top = 1200
Width = 3375
Begin VB.TextBox Text4
BackColor = &H00FFFFFF&
Height = 3135
Left = 120
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 4
Top = 240
Width = 3135
End
End
Begin VB.TextBox Text1
BackColor = &H00FFFFFF&
Height = 495
Left = 120
TabIndex = 2
Top = 600
Width = 3375
End
Begin VB.CommandButton Command4
BackColor = &H00FFFFC0&
Caption = "分 析"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 1080
TabIndex = 0
Top = 5280
UseMaskColor = -1 'True
Width = 1335
End
Begin VB.Label Label1
BackColor = &H80000013&
Caption = "请按顺序输入各分类的起止样本标号"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 120
TabIndex = 1
Top = 120
Width = 3375
End
End
Attribute VB_Name = "Form04"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Base 0
Private Sub Command4_Click()
'm = UBound(X, 1) 'x矩阵的行数
'n = UBound(X, 2) 'x矩阵的列数
'Dim k As Integer 'k为用户给出的分类数
'a = Split(Text2.Text, ",")
'k = 0
' For i = 1 To UBound(a)
' k = k + i
' Next i
'k = k / 2
'*****************************************
'以下为验证程序
'*****************************************
Dim A() As String, x1() As String
Const k% = 3
Const m% = 5
Const n% = 23
Dim x!(22, 4), aa!(5)
A = Split(Text1.Text, ",") '用split只能给字符型数组赋值
x1 = Split(Text4.Text, ",") '用split赋值的数组下标总是从0开始
For i = 0 To n - 1
For j = 0 To m - 1
x(i, j) = Val(x1(j + i * 5))
Next j
Next i
For i = 0 To UBound(A)
aa(i) = Val(A(i))
' Picture1.Print Tab(i * 5); aa(i);
Next i
'*****************************************
'以下为l,w矩阵的计算程序
'*****************************************
Dim sum!(), aver!(), tsum!, taver!()
Dim ll1!(), ww1!(), ll2!(), ww2!(), ll3!(), ww3!(), l!(), w!()
ReDim sum!(k - 1), aver!(m - 1, k - 1), taver!(m - 1)
ReDim ll1!(m - 1, m - 1), ww1!(m - 1, m - 1), ll2!(m - 1, m - 1), ww2!(m - 1, m - 1)
ReDim ll3!(m - 1, m - 1), ww3!(m - 1, m - 1), l!(m - 1, m - 1), w!(m - 1, m - 1)
Dim c As Integer 'c为控制过程变量
For t = 0 To m - 1
tsum = 0 'tsum是每列的总和
c = 0
For k1 = 0 To k - 1
sum(k1) = 0 'sum（k1）是每列不同分类样本的总和
aver(t, k1) = 0 'aver（t，k1）是不同分量不同分类的样本均值
For j = (aa(c) - 1) To (aa(c + 1) - 1)
sum(k1) = sum(k1) + x(j, t)
Next j
aver(t, k1) = sum(k1) / (aa(c + 1) - aa(c) + 1)
tsum = tsum + sum(k1)
c = c + 2
Next k1
taver(t) = tsum / n 'taver（t）为不同列样本的均值
Next t
' Picture1.Print "这是均值向量输出值"
' For t = 0 To m - 1
' For k1 = 0 To k - 1
' Picture1.Print Tab((k1 Mod 3) * 15); aver(t, k1);
' Next k1
' Next t
'
' For t = 0 To m - 1
' Picture1.Print Tab((t Mod 5) * 15); taver(t);
' Next t
c = 0
For i1 = 0 To m - 1
For i2 = 0 To m - 1
For j = (aa(0) - 1) To (aa(1) - 1)
ll1(i1, i2) = ll1(i1, i2) + (x(j, i1) - aver(i1, 0)) * (x(j, i2) - aver(i2, 0))
ww1(i1, i2) = ww1(i1, i2) + (x(j, i1) - taver(i1)) * (x(j, i2) - taver(i2))
Next j
c = c + 2
For j = (aa(2) - 1) To (aa(3) - 1)
ll2(i1, i2) = ll2(i1, i2) + (x(j, i1) - aver(i1, 1)) * (x(j, i2) - aver(i2, 1))
ww2(i1, i2) = ww2(i1, i2) + (x(j, i1) - taver(i1)) * (x(j, i2) - taver(i2))
Next j
c = c + 2
For j = (aa(4) - 1) To (aa(5) - 1)
ll3(i1, i2) = ll3(i1, i2) + (x(j, i1) - aver(i1, 2)) * (x(j, i2) - aver(i2, 2))
ww3(i1, i2) = ww3(i1, i2) + (x(j, i1) - taver(i1)) * (x(j, i2) - taver(i2))
Next j
Next i2
Next i1
For i1 = 0 To m - 1
For i2 = 0 To m - 1
l(i1, i2) = ll1(i1, i2) + ll2(i1, i2) + ll3(i1, i2)
w(i1, i2) = ww1(i1, i2) + ww2(i1, i2) + ww3(i1, i2)
Next i2
Next i1
Picture1.Print Tab(0); "**********************************************************"
Picture1.Print Tab(0); "这是l矩阵"
For m1 = 0 To m - 1
For n1 = 0 To m - 1
Picture1.Print Tab((n1 Mod 5) * 15); l(m1, n1);
Next n1
Next m1
Picture1.Print Tab(0); ""
Picture1.Print Tab(0); "这是w矩阵"
For m1 = 0 To m - 1
For n1 = 0 To m - 1
Picture1.Print Tab((n1 Mod 5) * 15); w(m1, n1);
Next n1
Next m1
'*******************************************
Dim u0!(m - 1), uu0!(m - 1), uuu0!(m - 1), getsma1!, getsma2!, getsma3!, locsma1%, locsma2%, locsma3%
Dim l1!(4, 4), w1!(4, 4), l2!(4, 4), w2!(4, 4), l3!(4, 4), w3!(4, 4), ff!, fff!
Dim lxx!(1, 1), S!(1, 1)
Const f1! = 2.62
Dim cnt%: cnt = 0
Call calu(u0(), l(), w())
Call min(u0(), getsma1, locsma1)
F = ((1 - getsma1) / getsma1) * ((n - k) / (k - 1))
If F > f1 Then
u0(cnt) = locsma1
Call change(l(), w(), locsma1, l1(), w1())
' Picture1.Print Tab(0); "这是l1矩阵"
' For m1 = 0 To m - 1
' For n1 = 0 To m - 1
' Picture1.Print Tab((n1 Mod 5) * 15); l1(m1, n1);
' Next n1
' Next m1
Call calu(uu0(), l1(), w1())
uu0(4) = l1(4, 4) / w1(4, 4)
getsma2 = uu0(4)
locsma2 = 4
ff = ((1 - getsma2) / getsma2) * ((n - k - 1) / (k - 1))
If ff > f1 Then
u0(1) = locsma2
Call change(l1(), w1(), locsma2, l2(), w2())
' Picture1.Print Tab(0); "这是l2矩阵"
' For m1 = 0 To m - 1
' For n1 = 0 To m - 1
' Picture1.Print Tab((n1 Mod 5) * 15); l2(m1, n1);
' Next n1
' Next m1
ul = w2(locsma1, locsma1) / l2(locsma1, locsma1)
uk = w2(locsma2, locsma2) / l2(locsma2, locsma2)
If ul < uk And ((1 - uk) / uk) * ((n - k - 1) / (k - 1)) > f1 Then
lxx(0, 0) = l2(locsma1, locsma1)
lxx(0, 1) = l2(locsma1, locsma2)
lxx(1, 0) = l2(locsma2, locsma1)
lxx(1, 1) = l2(locsma2, locsma2)
For i = 0 To 1
For j = 0 To 1
S(i, j) = (n - k) * lxx(i, j)
Next j
Next i
End If
End If
End If
'******************************
Picture1.Print Tab(0); ""
Picture1.Print Tab(0); "输出相关的结果："
Picture1.Print Tab(0); ""
Picture1.Print Tab(0); "*******************************************************************************"
Picture1.Print Tab(0); "以下是最终入选的变量指标"
Picture1.Print Tab(0); ""
Picture1.Print Tab(0); "第"; locsma1 + 1; "个变量和第"; locsma2 + 1; "个变量"
Picture1.Print Tab(0); "*******************************************************************************"
Picture1.Print Tab(0); ""
Picture1.Print Tab(0); "这是最终的组内离差阵删除未选入变量所对应的主元的行和列剩下的矩阵"
Picture1.Print Tab(0); ""
For i = 0 To 1
For j = 0 To 1
Picture1.Print Tab((j Mod 5) * 15); lxx(i, j);
Next j
Next i
Picture1.Print Tab(0); ""
Picture1.Print Tab(0); "这是入选变量的协方差的逆矩阵"
Picture1.Print Tab(0); ""
For i = 0 To 1
For j = 0 To 1
Picture1.Print Tab((j Mod 5) * 15); S(i, j);
Next j
Next i
End Sub
Sub calu(u() As Single, lo() As Single, wo() As Single) 'calu过程为计算变量的判别能力
For i = 0 To UBound(lo, 1) - 1
u(i) = lo(i, i) / wo(i, i)
'Picture1.Print u(i); "";
Next i
'Picture1.Print
End Sub
Sub min(A() As Single, getsma As Single, locsma As Integer) 'min过程为计算一组数值中最小的值并返回，返回位置
Dim min!, p#
min = A(0)
For i = 0 To UBound(A) - 1
If min > A(i) Then
min = A(i)
p = i
End If
Next i
getsma = A(p)
locsma = p
End Sub
Sub change(lo() As Single, wo() As Single, l As Integer, ll() As Single, ww() As Single) 'l1为变换后的l矩阵，w1为变换后的w矩阵
Dim i%, j As Integer
For i = 0 To 4
For j = 0 To 4
If i = l And j = l Then
ll(i, j) = 1 / lo(l, l)
ww(i, j) = 1 / wo(l, l)
ElseIf i = l And j <> l Then
ll(i, j) = lo(i, j) / lo(l, l)
ww(i, j) = wo(i, j) / wo(l, l)
ElseIf i <> l And j = l Then
ll(i, j) = -lo(i, l) / lo(l, l)
ww(i, j) = -wo(i, l) / wo(l, l)
ElseIf i <> l And j <> l Then
ll(i, j) = lo(i, j) - (lo(i, l) * lo(l, j)) / lo(l, l)
ww(i, j) = wo(i, j) - (wo(i, l) * wo(l, j)) / wo(l, l)
End If
Next j
Next i
End Sub
Private Sub Label3_Click()
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -