📄 form03.frm
字号:
Next j, i
End If
End Sub
Function Determinant(m1() As Double) As Double
'****************************************************************************************
' 功能 ： 求矩阵的行列式
' 参数 ： m1待求矩阵
' 返回值： Determinant返回m矩阵的行列式值，为Double类型
' 说明 ： 该函数运行后，矩阵m中的数据被改变
'****************************************************************************************
Dim i, j, kk, row, order, r, c As Long
Dim Pivot, Pivot2 As Single
Dim temp() As Double
Determinant = 1
row = UBound(m1, 1)
If UBound(m1, 2) <> row Then MsgBox "这不是方阵": Exit Function
ReDim temp(1 To row)
For i = 1 To row
Pivot = 0
For j = i To row
For kk = i To row
If Abs(m1(kk, j)) > Pivot Then
Pivot = Abs(m1(kk, j))
r = kk: c = j
End If
Next kk
Next j
If Pivot = 0 Then Determinant = 0: Exit Function
If r <> i Then
order = order + 1
For j = 1 To row
temp(j) = m1(i, j)
m1(i, j) = m1(r, j)
m1(r, j) = temp(j)
Next j
End If
If c <> i Then
order = order + 1
For j = 1 To row
temp(j) = m1(j, i)
m1(j, i) = m1(j, c)
m1(j, c) = temp(j)
Next j
End If
Pivot = m1(i, i)
Determinant = Determinant * Pivot
For j = i + 1 To row
Pivot2 = m1(j, i)
If Pivot2 <> 0 Then
For kk = 1 To row
m1(j, kk) = m1(j, kk) - m1(i, kk) * Pivot2 / Pivot
Next
End If
Next
Next
Determinant = Determinant * (-1) ^ order
End Function
Function SelectSort(px() As Double)
'****************************************************************************************
'功能： 用简单选择法进行排序（由大到小）
'参数： px矩阵的第一行为待排序的数列
'返回值： 排序后原矩阵px第一行存储排序后由大到小的结果，第二行存储对应的排序前的下标
'****************************************************************************************
For i = 1 To UBound(px(), 2) - 1
shao1 = i 'shao1做数据的哨兵
For j = i + 1 To UBound(px(), 2)
If (px(1, shao1) < px(1, j)) Then shao1 = j
Next j
If shao1 = i Then
px(2, i) = i
Else
shao2 = px(1, shao1) 'shao2做下标的哨兵
px(1, shao1) = px(1, i)
px(1, i) = shao2
px(2, i) = shao1
px(2, shao1) = i
End If
Next i
If px(2, i) = 0 Then px(2, i) = i
End Function
Private Sub Command1_Click()
For i = 1 To n
For j = 1 To m + 1
vsFlexArray1.row = i
vsFlexArray1.Col = j
vsFlexArray1.Text = ""
Next j, i
Text3.Text = ""
End Sub
Private Sub Command2_Click()
'n = Val(Text1.Text)
'm = Val(Text2.Text)
'k = Val(Text.Text)
'Me.Cls
'Dim Y(), X() As Double, Lxx() As Double, L() As Double, m%, n%, nn%, k%, k1(3) As Integer, k2(3) As Integer
ReDim k1(k): ReDim k2(k): ReDim x(m, n)
Dim xx() As Double: ReDim xx(m + 1, n)
If Option2.Value = True Then
Y = Split(Text3.Text, ",")
For i = 0 To UBound(Y)
xx(i Mod (m + 1) + 1, i \ (m + 1) + 1) = Val(Y(i))
Next i
Call putout(xx(), m + 1, n)
For i = 1 To n
For j = 1 To m
Print xx(j, i)
Next j, i
For i = 1 To n
For j = 1 To m
x(j, i) = xx(j, i)
Next j, i
pp = 1
k1(pp) = 1
For i = 2 To n
If (Val(xx(m + 1, i)) = pp) Then
k2(pp) = i
Else
k2(pp) = i - 1
pp = pp + 1
k1(pp) = i
End If
Next i
k2(pp) = n
ElseIf vsFlexArray1.Enabled = True Then
pp = 1
k1(pp) = 1
For i = 1 To n
vsFlexArray1.row = i
For j = 1 To m
vsFlexArray1.Col = j
x(j, i) = Val(vsFlexArray1.Text)
Next j, i
For i = 2 To n
vsFlexArray1.row = i
vsFlexArray1.Col = m + 1
If (Val(vsFlexArray1.Text) = pp) Then
k2(pp) = i
Else
k2(pp) = i - 1
pp = pp + 1
k1(pp) = i
End If
Next i
k2(pp) = n
End If
'************************************以下进行求平均运算*****************************************
Dim pj() As Double: ReDim pj(m, 1) '用来调用pingjun函数
Dim xzpj() As Double: ReDim xzpj(m, 1) '以m维行向量储存总体的平均值
Dim xpj() As Double: ReDim xpj(m, k) '以m*n矩阵储存n类的m维样本的平均值
For p = 1 To k
Call pingjun(x(), m, k1(p), k2(p), pj()) '调用平均函数,计算每类的平均值
For i = 1 To m
xpj(i, p) = pj(i, 1)
Next i, p
Call pingjun(x(), m, k1(1), k2(k), xzpj())
'Print "总平均为：";: Call putout(xzpj(), m, 1) '输出总平均
'************************************以下进行求离差运算******************************************
Dim lc() As Double, flag As Boolean '用来调用licha函数
Dim xlc() As Double: ReDim xlc(m, m) '总离差阵,即Lxx
Dim xlcn() As Double: ReDim xlcn(m, m) '总离差阵的逆
For p = 1 To k
Call licha(x(), m, k1(p), k2(p), lc()) '调用各类的离差阵
For i = 1 To m
For j = 1 To m
xlc(i, j) = xlc(i, j) + lc(i, j) '各类离差阵进行累加得到总体离差阵
Next j, i, p
Text5.Text = Text5.Text & vbNewLine & "总离差阵为：" & vbNewLine
For i = 1 To m
For j = 1 To m
Text5.Text = Text5.Text & Space(5) & xlc(i, j)
Next j
Text5.Text = Text5.Text & vbNewLine
Next i
Call MRinv(m, xlc(), xlcn(), flag) '调用求逆函数MRinv（），求离差阵的逆xlcn
If flag = False Then
Text5.Text = Text5.Text & vbNewLine & vbNewLine & "离差阵无逆矩阵,不能建立判别函数，请选用其他方法进行判别分析"
Exit Sub '强行退出过程，结束运算，以下的程序不再进行
End If
'*********************************以下为进行统计检验或判别分析做准备****************************
Dim z() As Double: ReDim z(m, k) 'z=(xpj(i)-xzpj)/(k2(i)-k1(i)+1) i=1……k
Dim z2() As Double: ReDim z2(k, m) 'z2存储z的转置矩阵
Dim B() As Double: ReDim B(m, m) 'B=z*z2为组间离差阵
Dim he() As Double: ReDim he(m, m) 'he矩阵储存Lxx+B，其中Lxx在计算中用xlc()表示
For i = 1 To m
For j = 1 To k
z(i, j) = (xpj(i, j) - xzpj(i, 1)) * Sqr(k2(j) - k1(j) + 1)
Next j, i
Call zhuanzhi(z(), z2())
Call chengfa(z(), z2(), B())
'Print: Print "B=z*z2为：";: Call putout(B(), m, m) '输出z与z2的乘积B
Call xiangjia(xlc(), B(), he())
'**************************************以下为进行统计检验***************************************
Dim xerf As Double '用来进行卡尔方分布检验
WILKS = Determinant(xlc()) / Determinant(he()) '威尔克斯分布统计量=|Lxx|/|Lxx+B|
Text5.Text = Text5.Text & vbNewLine & "经计算威尔克斯统计量|Lxx|/|Lxx+B|为：" & WILKS
WILKSd = -(n - 1 - (m + k) / 2) * Log(WILKS) '威尔克斯统计量的方差
Text5.Text = Text5.Text & Chr(13) & "，其方差V为：" & WILKSd
xerf = Val(InputBox(" 请输入自由度为" & m * (k - 1) & "的卡尔方分布在水平0.01处的值：", "统计检验"))
If WILKSd > xerf Then
Text5.Text = Text5.Text & vbNewLine & vbNewLine & "检验后可知，H01（各类总体均值相等）假设被否定,应建立判别函数。"
Else
Text5.Text = Text5.Text & vbNewLine & vbNewLine & "检验后可知，H01（各类总体的均值相等）假设被接受,无需建立判别函数。"
Exit Sub '无需进行判别分析，则强行退出过程，下面的程序不再进行
End If
'**************************************以下进行Fisher判别分析**********************************
'---------------------------------------首先求出第一判别函数-----------------------------------
Dim v() As Double, mv As Double 'mv存储按模最大的特征值，v存储其对应的特征向量
Dim vn() As Double: ReDim vn(1, m) 'vn为特征向量v的转置
Call chengfa(xlcn(), B(), z()) '离差阵的逆矩阵xlcn与B矩阵的乘积覆盖了原来的z阵
'Print "离差阵的逆矩阵与B矩阵的乘积为：": Call putout(z(), m, m)
Call tezheng(z(), mv, v())
Call zhuanzhi(v(), vn())
Text5.Text = Text5.Text & vbNewLine & vbNewLine & "所建立的判别函数x1,x2…xm项的系数为："
For i = 1 To m
Text5.Text = Text5.Text & Space(2) & vn(1, i) '以v的转置形式输出
Next i
Text5.Text = Text5.Text & vbNewLine & vbNewLine & "以下进行费希尔（Fisher）评判：(按照样品输入的顺序输出）--------------------------"
Dim fv As Double '用来储存回判结果的符合率，后面两种方法都用到
'------------------------Fisher判别方法一:用类间临界值划分的规则-----------------------------------
'计算每类关于判别函数的值，再排序，经每相邻两个加权取平均得k-1各标准，若对任一样品Xi，其对应的值yi，再与判别标准进行大小比较从而得到判别
Dim yzpj() As Double: ReDim yzpj(2, k)
'yzpj(2, k)进行排序后，第一行存储判别函数值由大到小的结果，第二行存储原判别函数值对应的下标
For p = 1 To k
For q = 1 To m
yzpj(1, p) = v(q, 1) * xpj(q, p) + yzpj(1, p)
Next q, p
'Call putout(yzpj(), 2, k) '输出各类对应的判别函数的值
Call SelectSort(yzpj())
Dim stand() As Double: ReDim stand(k - 1)
Text5.Text = Text5.Text & vbNewLine & vbNewLine & "类间临界值的辨别标准为："
For i = 1 To UBound(stand)
stand(i) = ((k2(yzpj(2, i)) - k1(yzpj(2, i)) + 1) * yzpj(1, i) + (k2(yzpj(2, i + 1)) - k1(yzpj(2, i + 1)) + 1) * yzpj(1, i + 1)) / (k2(yzpj(2, i)) - k1(yzpj(2, i)) + k2(yzpj(2, i + 1)) - k1(yzpj(2, i + 1)) + 2)
Text5.Text = Text5.Text & Space(2) & stand(i) '输出加权平均取得的标准
Next i
Dim jieguo() As Double: ReDim jieguo(1, n)
Call chengfa(vn(), x(), jieguo())
Text5.Text = Text5.Text & vbNewLine & "用类间临界值划分的判别结果为：" & vbNewLine & Space(5) '以下用标准进行判别
For p = 1 To UBound(k1())
For i = k1(p) To k2(p)
For j = 1 To UBound(stand())
If jieguo(1, i) >= stand(j) Then
jieguo(1, i) = yzpj(2, j)
Text5.Text = Text5.Text & Space(1) & jieguo(1, i) '输出此判别方法计算得到的类别
Exit For
End If
Next j
If j > UBound(stand()) Then
jieguo(1, i) = yzpj(2, j)
Text5.Text = Text5.Text & Space(1) & jieguo(1, i) '输出此判别方法计算得到的类别
End If
If jieguo(1, i) = p Then fv = fv + 1
Next i, p
fv = fv / UBound(jieguo(), 2)
Text5.Text = Text5.Text & vbNewLine & Space(5) & "该方法的回判结果的符合率为：" & Format(fv, "00.0000%")
'---------------------------Fisher判别分析方法二：用马氏距离的判别规则--------------------------------
'对任一样品Xi，求出其判别函数对应的值yi，再求出它与各体的马氏距离di，若di=min{dj}(j=1…k)，则判断Xi属于Gi
Dim cha() As Double: ReDim cha(m, n) 'cha用来存储样本总体X与各类平均xpj(1…m,i)(i=1,2…k)的差
Dim result() As Double: ReDim result(2, n) 'result的第一行存储距离最小的类别，第二行存储最小距离
Dim jg() As Double: ReDim jg(n, n) 'jg存储求总体的马氏距离方阵，其中对角线是求得的马氏距离
Dim f1() As Double: ReDim f1(1, n)
Dim f2() As Double: ReDim f2(n, 1)
Dim f3() As Double: ReDim f3(n, 1)
Dim g1() As Double: ReDim g1(1, m)
Dim g2() As Double: ReDim g2(1, 1)
Text5.Text = Text5.Text & vbNewLine & vbNewLine & "用马氏距离的判别结果为：" & vbNewLine & Space(5)
For p = 1 To k
For i = 1 To m
For j = 1 To n
cha(i, j) = x(i, j) - xpj(i, p) '求样本总体X与各类平均的差并用cha来存储
Next j, i
Call chengfa(vn(), cha(), f1()) '特征向量与差相乘放入f1
Call zhuanzhi(f1(), f2())
ReDim lc(m, m)
Call licha(x(), m, k1(p), k2(p), lc()) '调用各类的离差阵
For q1 = 1 To m
For q2 = 1 To m
lc(q1, q2) = lc(q1, q2) / (k2(p) - k1(p)) '结果为离差阵的无偏估计覆盖了原来的离差阵
Next q2, q1
Call chengfa(vn(), lc(), g1())
Call chengfa(g1(), v(), g2())
Call MRinv(1, g2(), g2(), flag) 'g2的逆覆盖了g2
Call chengfa(f2(), g2(), f3())
Call chengfa(f3(), f1(), jg()) 'jg存储求总体与第k类的马氏距离方阵，其中对角线是求得的马氏距离
If p = 1 Then
For r = 1 To n
result(1, r) = 1 'result(2, r)矩阵的初始化， 第一行全赋1，第2行赋总体与第1类的马氏距离
result(2, r) = jg(r, r):
Next r
Else
For r = 1 To n
If jg(r, r) < result(2, r) Then
'将刚求的马氏距离与result对应位置的进行比较，若比result中的小，则取代它的值，并记下该类类别
result(2, r) = jg(r, r):
result(1, r) = p
End If
Next r
End If
For i = 1 To n
Next i
Next p
For p = 1 To k '输出此判别方法计算得到的类别
For q = k1(p) To k2(p)
Text5.Text = Text5.Text & Space(1) & result(1, q)
If result(1, q) = p Then fv = fv + 1
Next q, p
fv = fv / n
Text5.Text = Text5.Text & vbNewLine & Space(5) & "该方法的回判结果的符合率为：" & Format(fv, "00.0000%")
'本程序用到自编的absF、 chengfa 、Determinant、 licha、 MRinv、 pingjun、 SelectSort、 putout 、tezheng 、VS 、xiangjia函数
End Sub
Private Sub Command3_Click()
form2.Show
End Sub
Private Sub Command4_Click()
End
End Sub
'Y = Array(45, 0.2, 1903, 1,250, 10.88, 208.92,1, 225, 19.2, 146.05,1, 240, 26.4, 223.1, 1,220, 26.4, 203.1,1, 240, 26.4, 223.1,1, 97.85, 3, 68.85, 1,240, 39.6, 219.9, 1,220, 39.6, 189.9,1, 240, 39.6, 209.9, 1,110, 4.95, 67.05,1, 132, 5.2, 92.72,1, 107.2, 5.2, 65.42,1, 130, 8.25, 127.25,1, 120, 8.25, 117.75, 1,49.6, 7.75, 6.25,2, 36.68, 5.2, 15.48,2, 21.9, 5.2, 7.12,2, 16.5, 12.29, -17.29,3, 20.5, 6.91, -5.41,3, 22.71, 3, 0.71, 3,11.82, 5.2, -2.91,3, 12.38, 5.2, -2.41,3, 6.78, 5.2, -8,3, 9.35, 5.2, -2.8,3, 14.7, 4.4, -13.7,3, 8.48, 5.2, -3.66,3)
Private Sub Form_Load()
vsFlexArray1.Visible = True
vsFlexArray1.Editable = False
Text3.Visible = True
Text3.Enabled = False
End Sub
Private Sub Option1_Click()
If Text1.Text = "" Then MsgBox ("请输入样本参数！"): Exit Sub
vsFlexArray1.Visible = True
vsFlexArray1.Enabled = True
vsFlexArray1.Editable = True
vsFlexArray1.row = 0
For i = 1 To m
vsFlexArray1.Col = i
vsFlexArray1.Text = "x" & i
Next
vsFlexArray1.Col = i
vsFlexArray1.Text = "预分类"
vsFlexArray1.Col = 0
For j = 1 To n
vsFlexArray1.row = j
vsFlexArray1.Text = j
Next
End Sub
Private Sub Option2_Click()
If Text1.Text = "" Then MsgBox ("请输入样本参数！"): Exit Sub
Text3.Visible = True
Text3.Enabled = True
Text3.SetFocus
End Sub
Private Sub Text1_Change()
n = Val(Text1.Text)
End Sub
Private Sub Text2_Change()
m = Val(Text2.Text)
End Sub
Private Sub Text4_Change()
k = Val(Text4.Text)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -