multiple.bas

多元线性回归:输入参数有样本长度（n)

Attribute VB_Name = "Multiple"
'// 多元线性回归
'
Function Multiple(n As Integer, k As Integer, X() As Single, Y() As Single, b() As Single) As Boolean

    Dim AV(101) As Single, S(101, 1001) As Single, R(101, 101) As Single
    Dim k1 As Integer
  ' On Error GoTo Warning
    
    FN = -1
    k1 = k + 1
    For i = 1 To n
        X(k1, i) = Y(i)
    Next i
    Covariance n, k1, X(), AV(), S()
    sumy = 0
    For i = 1 To n
        sumy = sumy + Y(i) * Y(i)
    Next i
    If sumy = 0 Then Exit Function
    
    SYY = sumy - AV(k1) * AV(k1) / n
    S(k1, k1) = Sqr(SYY)
    For i = 1 To k
        i1 = i + 1
        For j = i1 To k
            R(i, j) = S(i, j) / Sqr(S(i, i) * S(j, j))
            R(j, i) = R(i, j)
        Next j
    Next i
    For i = 1 To k
        R(i, i) = 1
        R(i, k1) = S(i, k1) / Sqr(S(i, i) * S(k1, k1))
    Next i
    GoSub GS
    For i = 1 To k
        b(i) = R(i, k1) * Sqr(S(k1, k1) / S(i, i))
    Next i
    E = 0: UU = 0
    For i = 1 To k
        E = E + b(i) * AV(i) / n
        UU = UU + b(i) * S(i, k1)
    Next i
    B0 = AV(k1) / n - E
    QQ = SYY - UU
    R0 = Sqr(UU / SYY)
    F0 = UU / QQ / k * (n - k - 1)
    S0 = Sqr(QQ / (n - 1))
    b(0) = B0
    
    Multiple = True
    Exit Function

GS:
   '--------------------------------------
    EP = 0.001
    For Z = 1 To k
        For io = Z To k
            If (Abs(R(io, Z)) - EP) <= 0 Then
                KOD = 1
            Else
                GoTo GS1
            End If
        Next io
    Next Z
    Return
GS1:
    If io <> Z Then
        For j = Z To k1
            tmp = R(Z, j)
            R(Z, j) = R(io, j)
            R(io, j) = tmp
        Next j
    End If
    T = 1 / R(Z, Z)
    For j = Z To k
        R(Z, j + 1) = T * R(Z, j + 1)
    Next j
    P = k - 1
    If Z <> k Then
        For i = io To P
            For j = Z To k
                R(i + 1, j + 1) = R(i + 1, j + 1) - R(i + 1, Z) * R(Z, j + 1)
            Next j
        Next i
    End If
    For ik = 2 To k
        i = k1 - ik
        For j = i To P
            R(i, k1) = R(i, k1) - R(i, j + 1) * R(j + 1, k1)
        Next j
    Next ik
    KOD = 0
    Return
Warning:
    MsgBox Err.Description, vbCritical
    Multiple = False
    
End Function