线性回归.frm

各类系统工程线性回归分析

      Height          =   255
      Left            =   840
      TabIndex        =   0
      Top             =   1440
      Width           =   1095
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim n As Variant
Dim i As Integer
Dim sum As Single
Dim x_ping As Single
Dim y_ping As Single
Dim Lxx As Single
Dim Lyy As Single
Dim Lxy As Single
Dim b As Single
Dim a As Single
Dim r As Single     'r为相关系数绝对值
Dim s As Single

Private Sub cmdanalyse_Click()
'验证数据合法性
 On Error GoTo cmdanalysehandler
 '画点
 Picture1.Cls
 For i = 0 To n - 1
    pointset txtx(i).Text, txty(i).Text
 Next i
'计算x_ping
sum = 0
For i = 0 To n - 1
sum = sum + txtx(i).Text
Next i
x_ping = sum / n
'计算y_ping
sum = 0
For i = 0 To n - 1
sum = sum + txty(i).Text
Next i
y_ping = sum / n

'计算Lxx
Lxx = 0
For i = 0 To n - 1
Lxx = Lxx + txtx(i).Text * txtx(i).Text
Next i
Lxx = Lxx - x_ping * n * x_ping
'计算Lyy
Lyy = 0
For i = 0 To n - 1
Lyy = Lyy + txty(i).Text * txty(i).Text
Next i
Lyy = Lyy - y_ping * n * y_ping

'计算Lxy
Lxy = 0
For i = 0 To n - 1
Lxy = Lxy + txtx(i).Text * txty(i).Text
Next i
Lxy = Lxy - x_ping * n * y_ping
'计算最大最小 x,y
Dim xmax As Single
Dim xmin As Single
Dim ymax As Single
Dim ymin As Single
xmax = txtx(0)
xmin = xmax
ymax = txty(0)
ymin = ymax
For i = 1 To n - 1
If xmax < txtx(i) Then xmax = txtx(i)
If xmin > txtx(i) Then xmin = txtx(i)
If ymax < txty(i) Then ymax = txty(i)
If ymin > txty(i) Then ymin = txty(i)
Next i
'特殊情况检查
If Lxx = 0 Then
Picture1.Line (counterpartx(x_ping), counterparty(ymin * 4 / 3 - ymax / 3))-(counterpartx(x_ping), counterparty(ymax * 4 / 3 - ymin / 3))
End If
If Lyy = 0 Then
Picture1.Line (counterpartx(xmin * 4 / 3 - xmax / 3), counterparty(y_ping))-(counterpartx(xmax * 4 / 3 - xmin / 3), counterparty(y_ping))
End If
If (Lxx = 0) And (Lyy = 0) Then
MsgBox ("所有点都重合了！")
Exit Sub
End If
If Lxx = 0 Then
MsgBox ("所有点都在一条竖直直线上！")
Exit Sub
End If
If Lyy = 0 Then
MsgBox ("所有点都在一条水平直线上！")
Exit Sub
End If
'计算b,a,r
b = Lxy / Lxx
a = y_ping - b * x_ping
r = Abs(Lxy / Sqr(Lxx * Lyy))
'计算离散度s
s = Sqr((Lxx * Lyy - Lxy * Lxy) / ((n - 2) * Lxx))


'得出线的起始，终了实际值
If b < 0 Then
xmin = (ymin - a) / b
xmax = (ymax - a) / b
End If
i = xmax + (xmax - xmin) / 5
xmin = xmin - (xmax - xmin) / 5
xmax = i
ymax = a + b * xmax
ymin = a + b * xmin
'最大最小 x,y转换成坐标值
xmax = counterpartx(xmax)
xmin = counterpartx(xmin)
ymax = counterparty(ymax)
ymin = counterparty(ymin)


'输出
Picresult.Cls
Picresult.Print
Picresult.Print " x="; x_ping
Picresult.Print " y="; y_ping
Picresult.Print " Lxx="; Lxx
Picresult.Print " Lyy="; Lyy
Picresult.Print " Lxy="; Lxy
Picresult.Print " b="; b
Picresult.Print " a="; a
Picresult.Print " r="; r
Picresult.Print " s="; s
cmdforesee.Enabled = True
'划线
Picture1.Line (xmin, ymin)-(xmax, ymax), RGB(0, 180, 0)

Exit Sub
cmdanalysehandler:
    Picresult.Cls
    Picresult.Print
    For i = 0 To n - 1
        If Not (IsNumeric(txtx(i).Text) And IsNumeric(txty(i).Text)) Then Picresult.Print " 第"; i + 1; "组元素不正确"
    Next i
    Picresult.Print
    If Not IsNumeric(xstart.Text) Then Picresult.Print " 请输入正确的 X轴 起始坐标"
    If Not IsNumeric(ystart.Text) Then Picresult.Print " 请输入正确的 Y轴 起始坐标"
    If Not IsNumeric(xend.Text) Then Picresult.Print " 请输入正确的 X轴 起始坐标"
    If Not IsNumeric(yend.Text) Then Picresult.Print " 请输入正确的 Y轴 起始坐标"
    
End Sub


Private Sub cmdforesee_Click()
Dim x0 As Variant
Dim y0 As Single
cmdanalyse_Click
On Error Resume Next
cycle: x0 = InputBox("输入X0", "输入X0", 50)
If Not IsNumeric(x0) Then Exit Sub
y0 = a + b * x0
Picresult.Cls
Picresult.Print
Picresult.Print " x="; x_ping
Picresult.Print " y="; y_ping
Picresult.Print " Lxx="; Lxx
Picresult.Print " Lyy="; Lyy
Picresult.Print " Lxy="; Lxy
Picresult.Print " b="; b
Picresult.Print " a="; a
Picresult.Print " r="; r
Picresult.Print " s="; s
Picresult.Print " X0="; x0; " 时"
Picresult.Print " 预测Y0="; y0
Picresult.Print " Y0置信度为95%的"
Picresult.Print " 置信区间为:"
Picresult.Print " [" & y0 - s * 1.96 & "," & Chr(13) & Chr(10) & "     " & y0 + s * 1.96 & "]"
End Sub

Private Sub Cmdrestart_Click()
Unload Me
Load Form1
Form1.Visible = True
Form1.Show
End Sub

Private Sub Form_Load()
Dim i As Integer
'输入n并验证合法性
On Error Resume Next
redo: n = InputBox("共有几组X,Y ？" & Chr(10) & Chr(13) & "(2<N<20)", "输入n", 5)
If n = "" Then End
If (Not IsNumeric(n)) Or n < 3 Or n > 20 Then GoTo redo
'界面初始化
For i = 1 To n - 1
Load txtx(i)
    txtx(i).Top = txtx(i - 1).Top + 300
    txtx(i).Visible = True
Load txty(i)
    txty(i).Top = txty(i - 1).Top + 300
    txty(i).Visible = True
Load Lindex(i)
    Lindex(i).Top = Lindex(i - 1).Top + 300
    Lindex(i).Visible = True
Next i
For i = 0 To n
 Lindex(i).Caption = i + 1
Next i
Me.Refresh
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture2.Cls
End Sub

Private Sub Picresult_Click()

End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture2.Cls
On Error GoTo picture1handler
Picture2.Print " 鼠标当前位置:"
Picture2.Print " x:"; X * (xend.Text - xstart.Text) / 6000 + xstart.Text
Picture2.Print " y:"; (6000 - Y) * (yend.Text - ystart.Text) / 6000 + ystart.Text
Exit Sub
picture1handler:
Picresult.Cls
Picresult.Print
Picture2.Cls
    If Not IsNumeric(xstart.Text) Then Picresult.Print " 请输入正确的 X轴 起始坐标"
    If Not IsNumeric(xend.Text) Then Picresult.Print " 请输入正确的 X轴 终了坐标"
    If Not IsNumeric(ystart.Text) Then Picresult.Print " 请输入正确的 Y轴 起始坐标"
    If Not IsNumeric(yend.Text) Then Picresult.Print " 请输入正确的 Y轴 终了坐标"

End Sub

Private Sub txtx_Change(Index As Integer)
cmdforesee.Enabled = False
Picresult.Cls
Picture1.Cls
Picture2.Cls

End Sub

Private Sub txty_Change(Index As Integer)
cmdforesee.Enabled = False
Picresult.Cls
Picture1.Cls
Picture2.Cls
End Sub

Private Sub xend_Change()
cmdforesee.Enabled = False
Picresult.Cls
Picture1.Cls
Picture2.Cls
End Sub

Private Sub xend_GotFocus()
xend.Text = ""
End Sub

Private Sub xstart_Change()
cmdforesee.Enabled = False
Picresult.Cls
Picture1.Cls
Picture2.Cls
End Sub

Private Sub xstart_GotFocus()
xstart.Text = ""
End Sub

Private Sub yend_Change()
cmdforesee.Enabled = False
Picresult.Cls
Picture1.Cls
Picture2.Cls

End Sub

Private Sub yend_GotFocus()
yend.Text = ""
End Sub

Private Sub ystart_Change()
cmdforesee.Enabled = False
Picresult.Cls
Picture1.Cls
Picture2.Cls
End Sub

Private Sub ystart_GotFocus()
ystart.Text = ""
End Sub
Private Sub pointset(ByVal X As Single, ByVal Y As Single)
X = counterpartx(X)
Y = counterparty(Y)
Picture1.Circle (X, Y), 20
End Sub
Private Function counterpartx(ByVal X As Single) As Single
counterpartx = 6000 * (X - xstart.Text) / (xend.Text - xstart.Text)
End Function
Private Function counterparty(ByVal Y As Single) As Single
counterparty = 6000 - 6000 * (Y - ystart.Text) / (yend.Text - ystart.Text)
End Function