form05.frm

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

     q = 1
     k1(q) = 1
     For i = 2 To n
         If (Val(xx(m + 1, i)) = 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
'*********************************************/////////// （1）数据准备 \\\\\\\\\****************************************


Dim pj() As Double                              '调用平均函数,以返回计算后的值
Dim xpj() As Double: ReDim xpj(m, k)            '每一个类的平均
Dim xzpj() As Double: ReDim xzpj(m, 1)          '总体的平均值,一维向量的形式
Dim xpjz() As Double: ReDim xpjz(m, k)          '所有类的均值向量构成的矩阵 ！！！请用户注意区分这两个变量名！！！
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)
        xpjz(i, p) = xpj(i, p)
        xzpj(i, 1) = xpj(i, p) + xzpj(i, 1)
Next i, p


For i = 1 To m
        xzpj(i, 1) = xzpj(i, 1) / k
Next i
'Print "总平均为："
'Call putout(xzpj(), m, 1)                      '输出总平均

'Print "总平均矩阵为:"
'Call putout(xpjz(), m, k)                      '输出平均的总矩阵

'
Dim lc() As Double                                '调用离差函数,用来返回结果
Dim xlc() As Double: ReDim xlc(m, m)              '总离差阵,即Lxx
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
'Print "离差阵为："
'Call putout(xlc(), m, m)                         '输出总离差阵


Dim dxlc() As Double: ReDim dxlc(m, m)                '输出Lxx的行列式的值
d0 = Determinant(xlc(), dxlc())
'Print "Lxx的行列式的值为:" & d0



Dim z() As Double: ReDim z(m, k)                 'z用以存储标准化后的数据
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


Dim z2() As Double: ReDim z2(k, m)                 'z2为z的转置
Call zhuanzhi(z(), z2())
'Call putout(z2(), k, m)

Dim B() As Double: ReDim B(m, m)                 'B=z*z2
Call chengfa(z(), z2(), B())
'Print "B=z*z2为："
'Call putout(B(), m, m)


Dim LB() As Double: ReDim LB(m, m)                  'LB()为Lxx+B()
For i = 1 To m
    For j = 1 To m
        LB(i, j) = xlc(i, j) + B(i, j)
Next j, i
Dim dLB() As Double: ReDim dLB(m, m)
d1 = Determinant(LB(), dLB())                    '输出|Lxx+B|的行列式的值
   'text5(0).Text = text5(0).Text & vbNewLine & "|Lxx+B|的值为:" & d1




Dim S() As Double: ReDim S(m, m)                   'S为离差阵的无偏估计
Dim mtxS() As Double: ReDim mtxS(m, m)             'mtxS为S调用求逆函数后返回的结果,即S的逆
For i = 1 To m
    For j = 1 To m
        S(i, j) = 1 / (n - k) * xlc(i, j)
Next j, i
'Print "输出S为:"
'Call putout(S(), m, m)


Dim flag As Boolean
Call MRinv(m, S(), mtxS(), flag)
'Print "输出S的逆为:"
'Call putout(mtxS(), m, m)
If flag = False Then
     Text5(0).Text = Text5(0).Text & vbNewLine & "离差阵无逆矩阵,不能用此方法进行判别分析!"
End If
'





'*******************************/////////// （2）统计检验 \\\\\\\\\**********************************************************************





Dim u As Double, v As Double
u = d0 / d1                         'u=Lxx/|Lxx+B|
v = (-1) * (n - 1 - (m + k) / 2) * Log(u)
'Print "                    u=" & u
'Print "                    v=" & v
X2 = Val(InputBox("请输入显著水平为0.01,卡方n=" & m * (k - 1) & " 的值"))
'X2 = 13.277

If v < X2 Then
         Text5(0).Text = Text5(0).Text & vbNewLine & "均值全相等！不需要进行进一步检验！"
        Exit Sub
    Else
        'Print "******************************************************************************************"
        Text5(0).Text = Text5(0).Text & vbNewLine & "否定均值全相等！进行进一步的检验！"





        '求出C矩阵
        Dim c() As Double: ReDim c(m, k)
        Call chengfa(mtxS(), xpjz(), c())
        'Print "矩阵C为:"
        'Call putout(C(), m, k)
        
        Dim C1() As Double: ReDim C1(m, k)              '用以记录求马氏距离的与C有关的矩阵,其中它是由C经过运算得到
        Dim x1() As Double: ReDim x1(m, k)              '用以记录求马氏距离的与X有关的矩阵,其中它是由X经过运算得到
        Dim juli() As Double: ReDim juli(k, k)
        For i = 1 To m
            For j = 1 To k - 1
                C1(i, j) = c(i, j) - c(i, j + 1)
                x1(i, j) = xpjz(i, j) - xpjz(i, j + 1)
            Next j
            C1(i, k) = c(i, k) - c(i, 1)
            x1(i, k) = xpjz(i, k) - xpjz(i, 1)
        Next i
        ' Print "C1="
        'Call putout(C1, m, k)
        'Print "X1="
        'Call putout(X1, m, k)
            
                
        Dim C2() As Double: ReDim C2(k, m)                   '记录C转置后的结果
        Call zhuanzhi(C1(), C2())
        'Print "C1转置后     *******"
        'Call putout(C2(), k, m)
        
        
        'Dim X2() As Double: ReDim X2(k, m)
        'Call zhuanzhi(X1(), X2())
        'Print "X1转置后     *******"
        'Call putout(X2(), k, m)
        

        Dim majuli() As Double: ReDim majuli(k, k)             '求马氏距离,返回
        Call chengfa(C2(), x1(), juli())
        For i = 1 To k - 1
            For j = i + 1 To k
                majuli(i, j) = juli(i, i)
                majuli(1, k) = juli(k, k)
                majuli(j, i) = majuli(i, j)
            Next j
            majuli(i, i) = 0
        Next i
        Text5(0).Text = Text5(0).Text & vbNewLine & "马氏距离为" & vbNewLine
        For i = 1 To k
        For j = 1 To k
         Text5(0).Text = Text5(0).Text & Space(5) & majuli(i, j)
         Next j
        Text5(0).Text = Text5(0).Text & vbNewLine
        Next i
       
       X3 = Val(InputBox("请输入显著水平为0.05,F(" & m & "," & n - m - k + 1 & ") 的值"))
        ' X3 = 3.52
        
        Dim F() As Double: ReDim F(k, k)
        For i = 1 To k
            For j = i + 1 To k
                F(i, j) = (n - m - k + 1) * (k2(i) - k1(i) + 1) * (k2(j) - k1(j) + 1) * majuli(i, j) / (m * (n - k) * (k2(i) - k1(i) + k2(j) - k1(j) + 2))
                F(i, i) = 0
                F(j, i) = F(i, j)
            Next j
        Next i
        'Print "F="
        'Call putout(F(), k, k)
        
        '********************************进行
        
        For w = 1 To k
            For r = w + 1 To k
                If F(w, r) < X3 Then
                   Text5(0).Text = Text5(0).Text & vbNewLine & "肯定第" & w & "个和第" & r & "个样本总体均值相等，不需要建立判别函数！"
                    Exit Sub
                Else
                  Text5(0).Text = Text5(0).Text & vbNewLine & "由F检验否定第" & w & "个和第" & r & "个样本总体均值相等，需建立判别函数进行判别！"
                                        '从这里开始进入以下判别函数的计算
                End If
            Next r
        Next w
        'Print "…………"



End If





'*******************************/////////// （3）计算判别函数 \\\\\\\\\**********************************************************************





'Print "******************************************************************************************"
'Print "进行判别函数的计算,如下:"
Dim C0() As Double: ReDim C0(k, 1)                  '判别函数的常数项系数矩阵
For j = 1 To k
    For i = 1 To m
        C0(j, 1) = C0(j, 1) - 1 / 2 * c(i, j) * xpjz(i, j)
    Next i
Next j
'Print "C0矩阵,即判别函数的常数项系数:"
'Call putout(C0(), k, 1)


Dim cc() As Double: ReDim cc(k, m)                  'cc为C的转置，用于以下的计算
Call zhuanzhi(c(), cc())
'Print "C转置后     *******"
'Call putout(cc(), k, m)


Dim ZX() As Double: ReDim ZX(k, m + 1)                    '判别函数的系数矩阵
For i = 1 To k
    ZX(i, 1) = Log((k2(i) - k1(i) + 1) / n) + C0(i, 1)
    For j = 2 To m + 1
        ZX(i, j) = cc(i, j - 1)
    Next j
Next i
Text5(0).Text = Text5(0).Text & vbNewLine & "判别函数见下,其中第一列为常数项系数,后列分别为x1、x2…的系数" & vbNewLine
'Call putout(ZX(), k, m + 1)
For i = 1 To k
        For j = 1 To m + 1
         Text5(0).Text = Text5(0).Text & Space(5) & ZX(i, j)
         Next j
        Text5(0).Text = Text5(0).Text & vbNewLine
        Next i



'*******************************/////////// （4）样品归类 \\\\\\\\\**********************************************************************




Dim ZPB() As Double: ReDim ZPB(k, n)                  '以下计算带入数据后的判别矩阵,ZPB为此判别矩阵

Dim ZX1() As Double: ReDim ZX1(k, m)            '过程量
For i = 1 To k
    For j = 1 To m
        ZX1(i, j) = ZX(i, j + 1)
Next j, i
'Call putout(ZX1(), k, m)
Call chengfa(ZX1(), x(), ZPB())





For i = 1 To k
    For j = 1 To n
        ZPB(i, j) = ZPB(i, j) + ZX(i, 1)         '增加常数项
Next j, i
'Print "带入数据后的判别矩阵结果"
'Call putout(ZPB(), k, n)


Dim hh() As Double: ReDim hh(n, k)               'hh为判别矩阵ZPB的转置，利于输出和计算
Call zhuanzhi(ZPB(), hh())
'Call putout(hh(), n, k)


'*****************进行分类，分类标准为带入判别函数后，最大的一项
Dim max() As Double: ReDim max(n)                     '记录行中最大值
ReDim Preserve hh(n, k + 1)                           '给判别函数结果矩阵增加一列,以保存对它分类后的结果
For i = 1 To n
    max(i) = hh(i, 1)
    hh(i, k + 1) = 1
    For j = 1 To k
        If max(i) < hh(i, j) Then
            max(i) = hh(i, j)
            hh(i, k + 1) = j
        End If
    Next j
Next i
'Print "输出判别函数计算后的结果,并进行分类"
'Call putout(hh(), n, k + 1)

'Print "输出每一样本的分类情况**************************************************************************************"
Text5(0).Text = Text5(0).Text & vbNewLine & " 分类号" & vbNewLine
Dim fenlei() As Double: ReDim fenlei(2, n)
For i = 1 To n
    fenlei(1, i) = i
    fenlei(2, i) = hh(i, k + 1)
    Text5(0).Text = Text5(0).Text & Space(2) & fenlei(2, i)
Next i

For i = 1 To 2
    For j = 1 To n
        'Print Tab(j * 5); fenlei(i, j);
    Next j
    Print
Next i




Dim xuhao() As Integer: ReDim xuhao(n)     '计算回判率,其中xuhao表示原来的预分类,count1计正确回判个数
Dim count1 As Integer
For i = 1 To n
    xuhao(i) = i
    For j = 1 To k
        If xuhao(i) >= k1(j) And xuhao(i) <= k2(j) Then
            xuhao(i) = j
            If xuhao(i) = fenlei(2, i) Then
                count1 = count1 + 1
            End If
        End If
    Next j
Next i
huipan = count1 / n                           'huipan表示回判率
Text5(0).Text = Text5(0).Text & vbNewLine & "回判率为:" & Format(huipan, "00.00%")



End Sub
Private Sub Command4_Click()
End
End Sub
Private Sub Form_Load()
vsFlexArray1.Visible = True
vsFlexArray1.Editable = False
Text3(1).Visible = True
Text3(1).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(1).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
End Sub
Private Sub Option2_Click()
If Text1.Text = "" Then MsgBox ("请输入样本参数！"): Exit Sub
Text3(1).Visible = True
Text3(1).Enabled = True
Text3(1).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