📄 趋势面分析f2.frm
字号:
Input #intFileNumber, vntA
Load lblCol(intI)
lblCol(intI).Caption = vntA
Next intI
'形成左边标签，但不在窗体上显示
For intI = 1 To intRowAll
Input #intFileNumber, vntA
Load lblRow(intI)
lblRow(intI).Caption = vntA
Next intI
lblF.Visible = False: lblNum(0).Visible = False
lblN(0).Visible = False: lblC(0).Visible = False
lbltV(0).Visible = False: lbltR(0).Visible = False
Close
End Sub
'计算
Private Sub cmdCalculate_Click()
Dim tt(300) As Single '保存t检验值
On Error Resume Next
If txtNN.Text = "" Then
MsgBox "在文本框中需填入趋势面的次数！"
txtNN.SetFocus
Exit Sub
End If
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
N0 = Val(txtNN.Text) 'N0为多项式的次数
NT = 1
For I = 1 To N0
NT = NT + (I + 1) 'NT为多项式的项数
Next
ReDim H(1 To NT), C(1 To NT, 1 To NT)
ReDim b(1 To M, 1 To N) '网格化后的结果
ReDim G(1 To M, 1 To N) '残差
'计算趋势面多项式的系数，并求观测点的趋势值和残差值
'X：数组，观测数据的X坐标
'Y：数组，观测数据的Y坐标
'Z：数组，观测数据的Z坐标
'N0：趋势面的次数
'H：数组，保存趋势面多项式的系数
'C：保存正规方程系数
'T：数组，保存观测点的趋势值
'D：数组，保存观测点的残差值
TREND X, Y, Z, N0, H, C, T, D
For I = 1 To intCol
Za = Za + Z(I)
Next I
Za = Za / intCol '因变量的平均值
'Syy是总离差平方和
For K = 1 To intCol
Zyy = Zyy + (Z(K) - Za) ^ 2
Next K
'U是回归平方和
For I = 1 To intCol 'intCol为观测点个数
w = 0
XX = X(I): YY = Y(I)
For J = 1 To NT '多项式的项数
Call Power(XX, YY, J, EE, FF)
w = H(J) * EE * FF + w
Next J
U = U + (w - Za) ^ 2
Next I
'Q是残差平方和
Q = Zyy - U
S2 = Q / (intCol - NT - 2) 'NT为系数的个数，包括常数项
F = (U / (NT - 1)) / S2 'F检验值
sngF = F: lblCV.Caption = sngF
UA = NT - 1: Ue = intCol - NT - 2
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 lblFR.Caption = "F检验结论：" & "不显著"
If F > F005 And F <= F001 Then lblFR.Caption = "F检验结论：" & "显著"
If F > F001 Then lblFR.Caption = "F检验结论：" & "特别显著"
sngC = U / Zyy * 100 '拟合度
If sngC < 100 Then
lblRR.Caption = "拟合度：" & Str(sngC) & "%"
Else
lblRR.Caption = "拟合度：" & Str(100) & "%"
End If
'求t检验值
S2 = Sqr(S2)
Invert C '求正规方程系数矩阵的逆矩阵
For I = 1 To NT - 1
tt(I) = Abs(H(I + 1) / S2 / Sqr(C(I, I)))
Next I
'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
'利用标签数组显示趋势面多项式系数及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 = H(I) 'H()保存趋势面多项式系数
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 = tt(I)
lbltV(I).Caption = Str(sngt) '显示t检验值
'显示结论
If tt(I) <= t005 Then lbltR(I) = "不显著"
If tt(I) > t005 And tt(I) <= t001 Then lbltR(I) = "显著"
If tt(I) > t001 Then lbltR(I) = "特别显著"
Next I
'网格插值
If Key = 1 Then GRID X, Y, H, b, G
'预测
If Key = 3 Then
lblNotice.Caption = "预测结果"
PreValue X0, Y0, NT, ZZ
sngZ = ZZ: txtNN = 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检验结论"
lbl005F.Caption = Str(sngF005): lbl001F.Caption = Str(sngF001)
For I = 1 To NT
If I + V <= NT Then
lblN(I).Caption = "": lblNum(I).Caption = Str(I + V)
sngC = H(I + V) 'H()保存趋势面多项式系数
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 = T(I + V)
lbltV(I).Caption = Str(sngt) '显示t检验值
'显示结论
If T(I + V) <= t005 Then lbltR(I) = "不显著"
If T(I + V) > t005 And T(I) <= t001 Then lbltR(I) = "显著"
If T(I + V) > t001 Then lbltR(I) = "特别显著"
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 = M
If blnRowLabel Then
intRowAll = intRowAll - 6 + 2 * M
Else
intRowAll = intRowAll - 3 + M
End If
intCol = N
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 = b(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 = G(intI - intN + 1, intJ)
txtData((intI - 1) * intCol + intJ) = sngR '数据
Next intJ
Next intI
'*****************************************************************
FileSave (strErr_Name)
Else
'保存平滑结果和残差
For intJ = 1 To intCol
sngR = T(intJ)
txtData((intRowAll - 1) * intCol + intJ) = sngR
Next intJ
FileSave (strRes_Name)
For intJ = 1 To intCol
sngR = D(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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -