二元多项式逐步回归f2.frm

<VB数理统计实用算法>书中的算法源程序

    Dim sngF As Single, sngH As Single
    Dim F005 As Double, F001 As Double
    Dim sngF005 As Single, sngF001 As Single
    Dim t005 As Double, t001 As Double
    Dim sngt005 As Single, sngt001 As Single
    Dim UA As Integer, Ue As Integer
    Dim I As Integer, J As Integer, K As Integer
    On Error Resume Next
    If txtN.Text = "" Then
        MsgBox "在文本框中需填入多项式的次数！"
        txtN.SetFocus
        Exit Sub
    End If
    If txtF1.Text = "" Or txtF2.Text = "" Then
        MsgBox "必须给定引入F和剔出F！"
        Exit Sub
    End If
    F1 = Val(txtF1.Text): F2 = Val(txtF2.Text)
    If F1 < F2 Then
        MsgBox "引入F不能小于剔出F！"
        Exit Sub
    End If
    If F1 = 0 And F2 = 0 Then MsgBox "F1 = F2 = 0 引入全部变量。不显示t检验"
    lblFC.Visible = True: lblCV.Visible = True
    lblf005.Visible = True: lbl005F.Visible = True
    lblf001.Visible = True: lbl001F.Visible = True
    lblFR.Visible = True: lblRR.Visible = True
    lblt005.Visible = True: lblt001.Visible = True
    lblTT.Visible = True: Line1.Visible = True
    lblCC.Visible = True: lblCR.Visible = True
    lblCoe.Visible = True: lblTT.Visible = True
    Line1.Visible = True
    N = intCol                      '数据点数
    M = Val(txtN.Text)              '最高幂次
    NT = 1
    For I = 1 To M
        NT = NT + (I + 1)           'NT为多项式的项数，包括常数项
    Next
    ReDim b(0 To NT - 1)            '保存回归系数数组
    ReDim H(1 To NT)                '保存回归系数数组,用于网格化
    ReDim Ti(1 To NT - 1)           't检验值数组
    ReDim xMy(1 To N, 1 To NT)      '变换后满足逐步回归要求的数据
'T、D保存网格化后的趋势值和残差
    ReDim T(1 To MM, 1 To NN), D(1 To MM, 1 To NN)
'对数据进行变换
    For I = 1 To N
        For J = 2 To NT
            Call Power(X(I), Y(I), J, EE, FF)
            xMy(I, J - 1) = EE * FF '变换后的自变量 = X和Y的乘幂
        Next J
        xMy(I, NT) = Z(I)           '相当于因变量Z
    Next I
    StrdM xMy, F1, F2, F, L, b, Ti  '建立回归方程并求F值和t值
    For I = 1 To NT
        H(I) = b(I - 1)
    Next I
    sngF = F
    lblCV.Caption = Str(sngF)
    UA = L: Ue = N - L - 1
    PF_DIST UA, Ue, 0.05, F005      '计算显著性为0.05的F临界值
    PF_DIST UA, Ue, 0.01, F001      '计算显著性为0.01的F临界值
    sngF005 = F005: sngF001 = F001
    lbl005F.Caption = Str(sngF005): lbl001F.Caption = Str(sngF001)
    If F <= F005 Then lblRR = "总的来看，自变量对因变量的影响不显著"
    If F > F005 And F <= F001 Then lblRR = "总的来看，自变量对因变量的影响显著"
    If F > F001 Then lblRR = "总的来看，自变量对因变量的影响特别显著"
    FFF = F * L / (N - L - 1)
    sngC = (1 - 1 / (1 + FFF)) * 100    '拟合度
    If sngC < 100 Then
        lblCR.Caption = Str(sngC) & "%"
    Else
        lblCR.Caption = Str(100) & "%"
    End If
't检测为双尾，在求临界值时，0.05和0.01都需除2
    PT_DIST Ue, 0.05 / 2, t005      '计算显著性为0.05的t临界值
    PT_DIST Ue, 0.01 / 2, t001      '计算显著性为0.01的t临界值
    sngt005 = t005: sngt001 = t001
    lblt005.Caption = sngt005: lblt001.Caption = sngt001
    If F1 = 0 Or F2 = 0 Then
        lblt005.Caption = "*****"
        lblt001.Caption = "*****"
    End If
'利用标签数组显示趋势面多项式系数及t检验
    lblF.Visible = True: lblNum(0).Visible = True
    lblN(0).Visible = True: lblC(0).Visible = True
    lbltV(0).Visible = True: lbltR(0).Visible = True
    sngH = lblN(0).Height                       '标签元素的高度
    For I = 1 To NT - 1                         '置放标签数组
        Load lblN(I): Load lblC(I): Load lbltV(I)
        Load lbltR(I): Load lblNum(I)
        lblN(I).Move lblN(0).Left, lblN(0).Top + I * sngH
        lblC(I).Move lblC(0).Left, lblC(0).Top + I * sngH
        lbltV(I).Move lbltV(0).Left, lbltV(0).Top + I * sngH
        lbltR(I).Move lbltR(0).Left, lbltR(0).Top + I * sngH
        lblNum(I).Move lblNum(0).Left, lblNum(0).Top + I * sngH
        lblN(I).Visible = True: lblC(I).Visible = True
        lbltV(I).Visible = True: lbltR(I).Visible = True
        lblNum(I).Visible = True
    Next I
    For I = 1 To NT
        lblNum(I).Caption = Str(I): lblN(I).Caption = ""
        sngC = b(I - 1)                         'b()保存趋势面多项式系数
        lblC(I - 1).Caption = Str(sngC)         '在标签数组显示多项式系数
'求趋势面各项的形式，以便在标签中显示X^2或Y^3等等
'I为项的次数
'intE为X的次数
'intF为Y的次数
        Term I, intE, intF
        If I > 1 Then
            If intE <> 0 Then lblN(I - 1).Caption = "X^" & Str(intE) & " "
            If intF <> 0 Then _
                lblN(I - 1).Caption = lblN(I - 1).Caption & "Y^" & Str(intF)
        End If
        sngt = Ti(I)
        lbltV(I).Caption = Str(sngt)            '显示t检验值
'显示结论
        If Ti(I) <= t005 Then lbltR(I) = "不显著"
        If Ti(I) > t005 And Ti(I) <= t001 Then lbltR(I) = "显著"
        If Ti(I) > t001 Then lbltR(I) = "特别显著"
        If F1 = 0 Or F2 = 0 Then
            lbltV(I).Caption = "*****"
            lbltR(I).Caption = "*****"
        End If
    Next I
'网格插值
    If Key = 1 Then GRID X, Y, H, T, D
'平滑处理
    If Key = 2 Then
    '**********************************************************
'回代进行平滑处理
        For I = 1 To N                          'N为观测点个数
            w = 0
            For J = 1 To NT                    '多项式的项数
                Call Power(X(I), Y(I), J, EE, FF)
                w = H(J) * EE * FF + w
            Next J
            G(I) = w                            '趋势值
            C(I) = Z(I) - w                     '残差值
        Next I
    End If
'预测
    If Key = 3 Then
        lblNotice.Caption = "预测结果"
        PreValue X0, Y0, NT, ZZ
        sngZ = ZZ: txtN = Str(sngZ)
    End If
'非“预测”情况下，使“保存”命令按钮可视
    If Not Key = 3 Then cmdSaveR.Visible = True
    cmdCalculate.Visible = False
End Sub

Private Sub VScroll1_Change()
    Dim V As Integer
    On Error Resume Next
    V = VScroll1.Value
    lblNum(0) = "序号": lbltV(0) = "t检验值": lbltR(0) = "t检验结论"
    For I = 1 To NT
        If I + V <= NT Then
            lblN(I).Caption = "": lblNum(I).Caption = Str(I + V)
            sngC = b(I + V - 1)                     'b()保存趋势面多项式系数
            lblC(I - 1).Caption = Str(sngC)         '显示多项式系数
'求趋势面各项的形式
'I为项的次数
'intE为X的次数
'intF为Y的次数
            Term I + V, intE, intF
            If I > 1 Then
                If intE <> 0 Then lblN(I - 1).Caption = "X^" & Str(intE) & " "
                If intF <> 0 Then _
                    lblN(I - 1).Caption = lblN(I - 1).Caption & "Y^" & Str(intF)
            End If
            sngt = Ti(I + V)
            lbltV(I).Caption = Str(sngt)            '显示t检验值
'显示结论
            If Ti(I + V) <= t005 Then lbltR(I) = "不显著"
            If Ti(I + V) > t005 And Ti(I) <= t001 Then lbltR(I) = "显著"
            If Ti(I + V) > t001 Then lbltR(I) = "特别显著"
            If F1 = 0 Or F2 = 0 Then
                lbltV(I).Caption = "*****"
                lbltR(I).Caption = "*****"
            End If
        Else
            lblNum(I - 1) = "": lblN(I) = "": lblC(I - 1) = ""
            lbltV(I - 1) = "": lbltR(I - 1) = ""
        End If
    Next I
End Sub

'将计算结果保存为数据文件
Private Sub cmdSaveR_Click()
    Dim sngR As Single, intN As Integer
    MsgBox "现在存盘，请耐心等待！"
    If blnOpt Then
'重新建立网格体系，需要先卸载原有的网格体系
        For intI = 1 To intRowAll
            For intJ = 1 To intCol
                Unload txtData((intI - 1) * intCol + intJ)
            Next intJ
        Next intI
        For intI = 1 To intCol
            Unload lblCol(intI)
        Next intI
        For intI = 1 To intRowAll
            Unload lblRow(intI)
        Next intI
'保存网格化数据
'网格化时的列数、行数、总行数都有可能改变，需要重新建立网格体系
'重新取得列数、行数、总行数
        intRow = MM
        If blnRowLabel Then
            intRowAll = intRowAll - 6 + 2 * MM
        Else
            intRowAll = intRowAll - 3 + MM
        End If
        intCol = NN
        For intI = 1 To intRowAll
            For intJ = 1 To intCol
                Load txtData((intI - 1) * intCol + intJ)
            Next intJ
        Next intI
        For intI = 1 To intCol
            Load lblCol(intI)
        Next intI
        For intI = 1 To intRowAll
            Load lblRow(intI)
        Next intI
        lblRow(1).Caption = "列数"
        txtData(1).Text = intCol                            '列数
        For intI = 2 To intCol
            txtData(intI) = "*******"
        Next intI
        lblRow(2).Caption = "行数"
        txtData(intCol + 1).Text = intRow                   '行数
        For intI = 2 To intCol
            txtData(intCol + intI) = "*******"
        Next intI
        lblRow(3).Caption = "总行数"
        txtData(2 * intCol + 1).Text = intRowAll            '总行数
        For intI = 2 To intCol
            txtData(2 * intCol + intI) = "*******"
        Next intI
        If blnTitle Then                                    '有标题
            lblRow(4).Caption = "标题"
            txtData(3 * intCol + 1).Text = "网格趋势"
            For intI = 2 To intCol
                txtData(3 * intCol + intI) = "*******"
            Next intI
            intN = 5
        End If
        If blnRowLabel Then                                 '有行标
            For intI = intN To intN + intRow - 1
                lblRow(intI).Caption = "行标" & (intI - intN + 1)
                txtData((intI - 1) * intCol + 1).Text = " "
                For intJ = 2 To intCol
                    txtData((intI - 1) * intCol + intJ).Text = "*******"
                Next intJ
            Next intI
            intN = intN + intRow
        End If
        If blnColLabel Then                                 '有列标
            lblRow(intN).Caption = "列标"
            For intI = 1 To intCol
                txtData((intN - 1) * intCol + intI) = " "
            Next intI
            intN = intN + 1
        End If
        For intI = intN To intRowAll
            lblRow(intI).Caption = "第" & (intI - intN + 1) & "行"
            For intJ = 1 To intCol
                sngR = T(intI - intN + 1, intJ)
                txtData((intI - 1) * intCol + intJ) = sngR  '数据
            Next intJ
        Next intI
        For intI = 1 To intCol
            lblCol(intI).Caption = "第" & intI & "列"
        Next intI
        FileSave (strRes_Name)                              '保存网格趋势
        intN = 4
        If blnTitle Then                                    '有标题
            txtData(3 * intCol + 1).Text = "网格残差"
            intN = 5
        End If
        If blnRowLabel Then intN = intN + intRow            '有行标
        If blnColLabel Then intN = intN + 1                 '有列标
        For intI = intN To intRowAll
            For intJ = 1 To intCol
                sngR = D(intI - intN + 1, intJ)
                txtData((intI - 1) * intCol + intJ) = sngR  '数据
            Next intJ
        Next intI
        FileSave (strErr_Name)                              '保存网格残差
    Else
'保存平滑结果和残差
        For intJ = 1 To intCol
            sngR = G(intJ)
            txtData((intRowAll - 1) * intCol + intJ) = sngR
        Next intJ
        FileSave (strRes_Name)
        For intJ = 1 To intCol
            sngR = C(intJ)
            txtData((intRowAll - 1) * intCol + intJ) = sngR
        Next intJ
        FileSave (strErr_Name)
    End If
    cmdCalculate.Visible = False
    cmdSaveR.Visible = False
    MsgBox "存盘完成，请退出！"
End Sub

'退出
Private Sub cmdExit_Click()
    Unload Me
    End
End Sub