用EXCEL VBA 计算一组数据的自相关函数和偏自相关函数

示例欢迎通过以下网址下载:
http://www.myfootprints.cn/blog/upload/ACF_PACF.xls

以下是vba 模块:

注:传入ACF()函数的参数必须是已经中心化后的数组。而传入PACF()函数的参数是由ACF()函数计算出来的数组序列。

使用中心化后的相同的数据在本Excel文件中和在SAS软件中计算的结果是一致的。

如:下载后示例文件后,将如下数据在SAS软件中计算其自相关函数与偏自相关函数:

-5.552941176
-3.352941176
-1.552941176
-4.152941176
-1.552941176
-4.152941176
-3.152941176
-2.152941176
-1.152941176
-0.152941176
0.847058824
1.847058824
2.847058824
3.847058824
4.847058824
5.847058824
6.847058824

SAS 程序为:

data mydata;
input x;
cards;
-5.552941176
-3.352941176
-1.552941176
-4.152941176
-1.552941176
-4.152941176
-3.152941176
-2.152941176
-1.152941176
-0.152941176
0.847058824
1.847058824
2.847058824
3.847058824
4.847058824
5.847058824
6.847058824
;
run;

proc arima;
identify var = x nlag = 864 outcov = out1;
run;

计算自相关函数的的自定义函数是acf(),偏自关函数是pacf(),它们的参数都是一组数据,而这组数据来自excel中的单元格范围,故它们都调用了一个函数,用来将excel的单元格范围转化成一个数组,这个函数就是range2array()。

range2array()的算法很简单,用for each循环将range中的每一个数字逐个填充到预先定义好的array()中。而这个array()的大小,与range中的单元格数相同。

acf()的算法,即是根据样本自相关函数的定义而实现的。即

而pacf()的算法,也是根据偏自相关函数的定义来的。即

在pacf()中,先根据输入的参数数组,分别得到分母矩阵和分子矩阵,然后分别对分母矩阵和分子矩阵求行列式值。最后相除即可。

分母矩阵实际上是一个对称矩阵,而且观察后可以发现有这样的规律,即,每个元素的下标,都是其行列号的差的绝对值

而分子矩阵,除了最后一列,其他的元素都与分母矩阵相同。

Option Explicit
'Option Private Module

''''''''''''''''''''''''''''''''''
' 计算列数据的自相关函数
'
''''''''''''''''''''''''''''''''''
Public Function ACF(ByRef rng As Range, ByVal k As Long) As Double
    Dim dDenominator As Double
    Dim dNumerator As Double
    Dim daX() As Variant
    Dim i As Long
    Dim lUB As Long, lLB As Long
    
    daX = Range2Array(rng)
    
    '计算分子
    dNumerator = 0
    lUB = UBound(daX)
    lLB = LBound(daX)
    For i = lLB + k To lUB
        dNumerator = dNumerator + daX(i) * daX(i - k)
    Next i
    
    '计算分母
    dDenominator = 0
    For i = lLB To lUB
        dDenominator = dDenominator + daX(i) * daX(i)
    Next i
    
    ACF = dNumerator / dDenominator
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 计算列数据的偏自相关函数
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function PACF(ByRef rng As Range, ByVal k As Long) As Double
    Dim dDenominator As Double
    Dim dNumerator As Double
    Dim dMatrixDenominator() As Double
    Dim dMatrixNumerator() As Double
    Dim vArray() As Variant
    Dim i As Long, j As Long
    Dim sString As String
    
    vArray = Range2Array(rng, 1)
    vArray(LBound(vArray)) = 1
    
    ReDim dMatrixDenominator(0 To k - 1, 0 To k - 1)
    ReDim dMatrixNumerator(0 To k - 1, 0 To k - 1)
    
    '生成分母矩阵
'    sString = "分母矩阵:" & vbCrLf
    
    For i = 0 To k - 1
        For j = 0 To k - 1
            dMatrixDenominator(i, j) = CDbl(vArray(Abs(i - j)))
'            sString = sString & dMatrixDenominator(i, j) & vbTab
        Next j
'        sString = sString & vbCrLf
    Next i
'    Debug.Print sString
    
    '生成分子矩阵
    For i = 0 To k - 1
        For j = 0 To k - 2
            dMatrixNumerator(i, j) = CDbl(vArray(Abs(i - j)))
        Next j
    Next i
    For i = 0 To k - 1
        dMatrixNumerator(i, k - 1) = CDbl(vArray(i + 1))
    Next i
    
'    sString = "分子矩阵:" & vbCrLf
'    For i = 0 To k - 1
'        For j = 0 To k - 1
'            sString = sString & dMatrixNumerator(i, j) & vbTab
'        Next j
'        sString = sString & vbCrLf
'    Next i
'    Debug.Print sString
    
    '计算PACF(k,k)
    PACF = Application.WorksheetFunction.MDeterm(dMatrixNumerator) / Application.WorksheetFunction.MDeterm(dMatrixDenominator)
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 求和
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function SigmaSum(ByRef rng As Range, ByVal lBegin As Long, ByVal lEnd As Long, ByVal power As Double) As Double
    SigmaSum = 0
    
    Dim i As Long
    
    For i = lBegin To lEnd
        SigmaSum = SigmaSum + CDbl(rng.Cells(i).Value) ^ power
    Next i
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 将Range转换成数组 (变体型)
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function Range2Array(ByRef rng As Range, Optional ByVal lOffset As Long = 0) As Variant()
    Dim vaRet() As Variant
    Dim i As Long
    Dim rngCell As Range
    
    ReDim vaRet(0 To rng.Cells.Count - 1)
    i = lOffset
    For Each rngCell In rng
        vaRet(i) = rngCell.Value
        If i >= UBound(vaRet) Then
            Exit For
        End If
        i = i + 1
    Next rngCell
    
    Range2Array = vaRet
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 将Range转换成数组 (双精度型)
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function Range2ArrayDouble(ByRef rng As Range) As Double()
    Dim daRet() As Double
    Dim i As Long
    Dim rngCell As Range
    
    ReDim vaRet(0 To rng.Cells.Count - 1)
    i = 0
    For Each rngCell In rng
        On Error Resume Next
        daRet(i) = CDbl(rngCell.Value)
        If Err.Number <> 0 Then
            daRet(i) = 0
            Err.Clear
        End If
        i = i + 1
    Next rngCell
    
    Range2ArrayDouble = daRet
End Function

 

示例文件:ACF_PACF.xls

Add comment

Loading