form02.frm

本文档包括了对软件中用到的多元统计分析中判别分析与聚类分析的主要方法(包括距离判别分析,费希尔判别分析,贝叶斯判别分析,逐步判别分析及聚类分析)原理及在本软件中使用的基本方法与设计流程图进行了详尽的阐

    For i = 1 To n
        If (i <> k) Then
            For j = 1 To n
                If (j <> k) Then mtxA(i, j) = mtxA(i, j) - mtxA(i, k) * mtxA(k, j)
            Next j
        End If
    Next i
    For i = 1 To n
        If (i <> k) Then mtxA(i, k) = -mtxA(i, k) * mtxA(k, k)
    Next i
Next k
For k = n To 1 Step -1 ' 调整恢复行列次序
    If (nJs(k) <> k) Then
      For j = 1 To n
          p = mtxA(k, j)
          mtxA(k, j) = mtxA(nJs(k), j)
          mtxA(nJs(k), j) = p
      Next j
    End If
    If (nIs(k) <> k) Then
      For i = 1 To n
          p = mtxA(i, k)
          mtxA(i, k) = mtxA(i, nIs(k))
          mtxA(i, nIs(k)) = p
      Next i
    End If
Next k
flag = True ' 求解成功
End Sub
Sub min(A() As Double, F() As Double) '求数组a各列（向量）的最小值
'****************************************************************************************
'  功能  ：  求解a()矩阵各列的最小值
'  参数  ：  a为待求矩阵；f为求得的a矩阵中最小的那列矩阵
'  返回值： f矩阵
'****************************************************************************************
ReDim F(UBound(A, 1), 1) As Double
    For i = 1 To UBound(A, 1)
        For j = 1 To UBound(A, 2) - 2
          For p = j + 1 To UBound(A, 2) - 2
            F(i, 1) = IIf(A(i, j) <= A(i, p), A(i, j), A(i, p))
          Next p
        Next j
    Next i
End Sub
Private Sub Command1_Click()
For i = 1 To n
    For j = 1 To m
        vsFlexArray1.row = i
        vsFlexArray1.Col = j
        vsFlexArray1.Text = ""
    Next j, i
Text3.Text = ""
End Sub
Private Sub Command2_Click()
Dim x() As Double, xI() As String, i%, j%, k1() As Integer, k2() As Integer, m%, n%, k%
Dim p%, q%
'Me.Cls
n = Val(Text1.Text)
m = Val(Text2.Text)
k = Val(Text4.Text)
ReDim k1(k) As Integer, k2(k) As Integer, x(n, m) As Double
Dim xx() As Double: ReDim xx(n, m + 1)
If Text3.Enabled = True Then
    xI = Split(Text3.Text, ",")
    For i = 0 To UBound(xI)
        xx(i \ (m + 1) + 1, i Mod (m + 1) + 1) = Val(xI(i))
    Next i
    For i = 1 To n
         For j = 1 To m
         x(i, j) = xx(i, j)
     Next j, i
     q = 1
     k1(q) = 1
     For i = 2 To n
         If (Val(xx(i, m + 1)) = q) Then
             k2(q) = i
         Else
             k2(q) = i - 1
             q = q + 1
             k1(q) = i
         End If
     Next i
     k2(q) = n
ElseIf vsFlexArray1.Enabled = True Then
    q = 1
    k1(q) = 1
    For i = 1 To n
        vsFlexArray1.row = i
        For j = 1 To m
        vsFlexArray1.Col = j
        x(i, j) = Val(vsFlexArray1.Text)
    Next j, i
    For i = 2 To n
        vsFlexArray1.row = i
        vsFlexArray1.Col = m + 1
        If (Val(vsFlexArray1.Text) = q) Then
            k2(q) = i
        Else
            k2(q) = i - 1
            q = q + 1
            k1(q) = i
        End If
    Next i
    k2(q) = n
End If
'For j = 1 To k
'        Print k1(j); 'k2(j);
'    Print
'Next j
'Call putout(X(), n, m)  '输出整个数据组
'**********************************************************************************************************************************************
'要用到的变量名定义
Dim pj() As Double
Dim xpj() As Double: ReDim xpj(m, k) 'xpj()为各类总体的平均值
Dim xpjz() As Double: ReDim xpjz(k, m) 'xpjz()为xpj()的转置
Dim xzpj() As Double: ReDim xzpj(m, 1) 'xzpj()为各类总体平均值的总平均值
Dim xcpj1() As Double: ReDim xcpj1(m, 1) 'xcpj1()是k=2时两类平均值的差值
Dim xcpj1z() As Double: ReDim xcpj1z(1, m) 'xcpj1z()是xcpj()的转置

'求解各列平均值及总平均值
For p = 1 To k
    Call pingjun(x(), m, k1(p), k2(p), pj())
    For i = 1 To m
    xpj(i, p) = pj(i)
    xzpj(i, 1) = xpj(i, p) + xzpj(i, 1)
Next i, p
For i = 1 To m
    xzpj(i, 1) = xzpj(i, 1) / k
    xcpj1(i, 1) = xpj(i, 1) - xpj(i, 2)
Next i
Call zhuanzhi(xpj(), xpjz())
Call zhuanzhi(xcpj1(), xcpj1z())

'变量定义
Dim lc() As Double: ReDim lc(m, m)  '各类离差阵定义
Dim xlc() As Double: ReDim xlc(m, m) '总离差阵为xlc(m,m)
Dim xlcy() As Double: ReDim xlcy(m, m) '总离差阵的逆定义
Dim S() As Double: ReDim S(m, m) '无偏估计的定义
Dim flag As Boolean
Dim jieguo() As Double: ReDim jieguo(n, k + 2)  '最终要显示的马氏距离及分类结果表，
'表的前k列显示的k类样品到总体的马氏距离,后一列显示分类情况，最后一列显示共有多少行样品


'总离差阵L
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
    Next i
Next p
Call MRinv(m, xlc(), xlcy(), flag)

'求解两总体的判别函数的系数及常数项
Dim xishu() As Double: ReDim xishu(1, m) '判别函数的系数
Call chengfa(xcpj1z(), xlcy(), xishu())
For i = 1 To m
   xishu(1, i) = ((n - k) / 2) * xishu(1, i)
Next i
Dim csx() As Double: ReDim csx(1, 1) '判别函数的常数项
For i = 1 To m
   xzpj(i, 1) = (-1) * xzpj(i, 1)
Next i
Call chengfa(xishu(), xzpj(), csx())
'两总体判别函数情况输出结果***********************************************************************
If k = 2 Then Text5.Text = "判别函数的系数为："
'Call putout(xishu(), 1, m)
For i = 1 To m
Text5.Text = Text5.Text & Space(5) & xishu(1, i)
Next i
Text5.Text = Text5.Text & vbNewLine & "判别函数的常数项为："
'Call putout(csx(), 1, 1)
Text5.Text = Text5.Text & csx(1, 1)
'**************************************************************************************************
'**************************************************************************************************
'下面是多总体（包括两个总体的情形）正态协方差阵在相等和不等两种情形下的马氏距离代码
Dim u%
u = Val(InputBox("如果假设总体协方差阵相等输入1，如果不相等则输入0"))
For p = 1 To k
'各类离差阵
Dim lcy() As Double: ReDim lcy(m, m)
   If u = 1 Then   '假设总体协方差阵相等
        Call licha(x(), m, k1(p), k2(p), lc())  '调用离差函数求解各类离差阵
       Call MRinv(m, lc(), lcy(), flag)         '调用求逆函数求解各类离差阵的逆
        lcy(m, m) = lcy(m, m)                   '将算出的离差阵统一赋给矩阵lcy()
        For i = 1 To m
           For j = 1 To m
              S(i, j) = (k2(p) - k1(p) + 1 - 1) * lcy(i, j)   '总体协方差阵的无偏估计
           Next j, i
   Else:          '假设总体协方差阵不相等
        For i = 1 To m
           For j = 1 To m
             lcy(i, j) = xlcy(i, j)            '将算出的总离差阵统一赋给矩阵lcy()
              Next j, i
              For i = 1 To m
        For j = 1 To m
            S(i, j) = (n - k) * lcy(i, j)
        Next j, i
  End If
   
    '求解各组值与各类平均的差值
    Dim xcpj() As Double: ReDim xcpj(n, m)
    For i = 1 To n
        For j = 1 To m
            xcpj(i, j) = x(i, j) - xpjz(p, j)   '求解样本各行值与各类平均值的差值
        Next j
    Next i
   Dim xcpjz() As Double: ReDim xcpjz(m, n)
   Call zhuanzhi(xcpj(), xcpjz())             '将上面求解得出的差值进行转置，形成m行n列矩阵
   Dim chengji() As Double: ReDim chengji(n, m)
   Call chengfa(xcpj(), S(), chengji())       '调用乘法函数求解平均值差值与无偏估计的乘积
    Dim d() As Double: ReDim d(n, n)
   Call chengfa(chengji(), xcpjz(), d())      '再次调乘法函数求解上面求得的乘积结果与平均差值转置的乘积
   For i = 1 To n
   jieguo(i, p) = jieguo(i, p) + d(i, i)      '求得的d()矩阵的对角线就是所要得到的马氏距离
   Next i
Next p
'*************************************************************************************************
'将上面求出的马氏距离进行整理放到一个矩阵中显示
Dim bijiao() As Double: ReDim bijiao(n, 1)
Call min(jieguo(), bijiao())              '调用求最小值函数求解上面jieguo()中各列最小的值并存放到一列中以bijiao()这个矩阵显示出来
For i = 1 To UBound(jieguo, 1)
  For j = 1 To UBound(jieguo, 2) - 2
   If jieguo(i, j) = bijiao(i, 1) Then
      jieguo(i, k + 1) = j                '将分类结果放到上面马氏距离那个矩阵的后一列中显示
      jieguo(i, k + 2) = i                '将样本个数放到分类结果的后一列中显示
      End If
   Next j
Next i
'多个总体（包括两个总体的情况）马氏距离及分类的输出
Text5.Text = Text5.Text & vbNewLine & "依据你的假设样品到各总体的类别为：" & vbNewLine
'Call putout(jieguo(), n, k + 2)
For i = 1 To n
  For j = 1 To k + 2
      Text5.Text = Text5.Text & Space(5) & jieguo(i, j)
Next j
Text5.Text = Text5.Text & vbNewLine
Next i
End Sub
Private Sub Command4_Click()
End
End Sub
Private Sub Form_Load()
vsFlexArray1.Visible = True
vsFlexArray1.Editable = False
Text3.Visible = True
Text3.Enabled = False
End Sub
Private Sub Option1_Click()
n = Val(Text1.Text)
m = Val(Text2.Text)
k = Val(Text4.Text)
If Text1.Text = "" Then MsgBox ("请输入样本参数！"): Exit Sub
'Text3.Height = 0
'vsFlexArray1.Height = 2000
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 j
End Sub
Private Sub Option2_Click()
If Text1.Text = "" Then MsgBox ("请输入样本参数！"): Exit Sub
Text3.Visible = True
Text3.Enabled = True
Text3.SetFocus
'vsFlexArray1.Visible = False
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