Market Research and Statistics Excel add-in Part 3

I've updated the Excel add-in. It's now on version 0.6.13.

Most of the changes are bug fixes but I've added some functionality. Most notably these are:

• Partial auto-correlation function
• Generate a set of frequency tables from a data set
• List file details in a folder

The full list of changes since version 0.6 and the add-in itself are on:

• sciolist.weebly.com
• http://sourceforge.net/projects/surveyscience

Comments on the add-in are very welcome.

Excel macro for partial auto correlation

Introduction

Partial auto-correlation (PACF) is useful in time series analysis. It is generally used with the auto-correlation coefficient for determining the order of the ARIMA processes to be fitted to whatever data set you may have.

According to Dr. Roland Fuss 'the partial auto-correlation describes the supplementary information provided by the additional lag'. Lag in this sense being the time difference between one point and another.

Essentially you use the ACF and PACF to determine what equation to fit to a set of time series data.

The equations that describe the PACF are as follows:

The value in the first equation is what we're interested in.

The Macro

The heart of the macro is contained within the following few lines of code:

1    t(0, 0) = 1
2    t(1, 1) = p(1)
3    For k = 2 To maxLag
4        'Calculate factors to take away from p(i)'
5        totalt = 0
6        For j = 1 To k - 1
7            If k - 1 <> j And k - 2 > 0 Then
8                t(k - 1, j) = t(k - 2, j) - t(k - 1, k - 1) * t(k - 2, k - 1 - j)
9            End If
10           totalt = totalt + t(k - 1, j) * p(k - j)
11       Next
12       t(k, k) = (p(k) - totalt) / (1 - totalt)
13        
14   Next

All this macro is doing is taking the auto-correlations, held in p(), and calculating the partial auto-correlations, the t() values or pi in the equation. It's very simple but does assume that all values of t(k,j) for smaller values of k and j have already been calculated.

Line 8 holds equation 2 and calculates the value of t() when k and j are not the same. Otherwise it is assumed that the values have already been calculated.

Lines 6 to 12 hold equation 1.

The bulk of the macro loads the data set, calculates the auto-correlations and only then calculates the partial auto-correlations. It's detailed next.

The Complete Code

And here is the complete PACF function for Excel:

Function PAutoCor(dataRange As range, Optional lag As Variant, Optional diff As Variant) As Variant
    Dim x() As Double           'Array to hold data values'
    Dim lags() As Integer       'Array to hold lag values'
    Dim sx As Double
    Dim sy As Double
    Dim s1 As Double
    Dim s2 As Double
    Dim s3 As Double
    Dim i, k As Integer         'Loop variables'
    Dim outputRows As Long
    Dim outputCols As Long
    Dim output() As Variant     'Temporary output array'
    Dim vertOutput As Boolean
    Dim vertInput As Boolean
    Dim vertLag As Boolean
    Dim numLags As Integer
    Dim maxLag As Integer
    Dim a As Integer
    Dim b As Integer
    Dim dataSize As Integer
    Dim p() As Double
    Dim t() As Double
    Dim j As Integer
    Dim totalt As Double
    
    'How many lags are there to calculate for?'
    With Application.Caller
        outputRows = .Rows.Count
        outputCols = .Columns.Count
    End With
    ReDim output(1 To outputRows, 1 To outputCols)
    
    'Vertical or horizontal output?'
    If outputRows > outputCols Then
        vertOutput = True
        numLags = outputRows
        'Set all output() to "#N/A"'
        For i = 1 To outputRows
            output(i, 1) = CVErr(xlErrNA)
        Next
    Else
        vertOutput = False
        numLags = outputCols
        'Set all output() to "#N/A"'
        For i = 1 To outputCols
            output(1, i) = CVErr(xlErrNA)
        Next
    End If
    
    'Vertical or horizontal input?'
    If dataRange.Rows.Count > dataRange.Columns.Count Then
        vertInput = True
        a = 1
        b = 0
        dataSize = dataRange.Rows.Count - 1
    Else
        vertInput = False
        a = 0
        b = 1
        dataSize = dataRange.Columns.Count - 1
    End If
    ReDim x(dataSize)
    
    'Check that lag is there'
    If IsMissing(lag) Then
        ReDim lags(numLags)
        'Populate lags'
        For i = 1 To numLags
            lags(i) = i
        Next
    ElseIf TypeName(lag) = "Range" Then
        'Horizontal or vertical lag'
        If lag.Rows.Count > lag.Columns.Count Then
            vertLag = True
            'Check that lag range matches output range in size'
            'Need to change this for maxLag'
            If lag.Rows.Count <> numLags Then numLags = lag.Rows.Count
            ReDim lags(numLags)
            maxLag = 0
            'Populate lags'
            For i = 1 To numLags
                lags(i) = lag(i, 1).Value
                If lags(i) > maxLag Then maxLag = lags(i)
            Next
        Else
            vertLag = False
            'Check that lag range matches output range in size'
            If lag.Columns.Count <> numLags Then numLags = lag.Columns.Count
            ReDim lags(numLags)
            maxLag = 0
            'Populate lags'
            For i = 1 To numLags
                lags(i) = lag(1, i).Value
                If lags(i) > maxLag Then maxLag = lags(i)
            Next
        End If
    Else
        'Should I check for array/single values?'
        ReDim lags(1)
        'Need to check if integer'
        lags(1) = lag
        'Set numLags to 1 just in case'
        numLags = 1
    End If
    
    'Check that diff is there'
    If IsMissing(diff) Then
        diff = 0
    End If
    
    'Fill data array x()'
    If diff > 0 Then
        For i = 0 To dataSize - 1
            If vertInput Then
                x(i) = dataRange(i + 1, 1).Value - dataRange(i + 2, 1).Value
            Else
                x(i) = dataRange(1, i + 1).Value - dataRange(1, i + 2).Value
            End If
        Next
    Else
        For i = 0 To dataSize
            If vertInput Then
                x(i) = dataRange(i + 1, 1).Value
            Else
                x(i) = dataRange(1, i + 1).Value
            End If
        Next
    End If
    
    If diff > 1 Then
        For k = 1 To diff
            For i = 0 To dataSize - 1 - k
                x(i) = x(i) - x(i + 1)
            Next
        Next
    End If
    
    'Redim for maxlag'
    ReDim p(maxLag)
    ReDim t(maxLag, maxLag)
    
    'Calculate autocorrelation'
    For i = 0 To maxLag
        sx = 0
        sy = 0
        s1 = 0
        s2 = 0
        s3 = 0
        For k = 0 To dataSize - i - diff
            sx = x(k) + sx
            sy = x(k + i) + sy
        Next
        sx = sx / (dataSize + 1 - i - diff)
        sy = sy / (dataSize + 1 - i - diff)
        
        For k = 0 To dataSize - i - diff
            s1 = s1 + (x(k) - sx) * (x(k + i) - sy)
            s2 = s2 + (x(k) - sx) ^ 2
            s3 = s3 + (x(k + i) - sy) ^ 2
        Next
        
        p(i) = s1 / Sqr(s2 * s3)
    Next
    
    'Set all ts to zero'
    For k = 1 To maxLag
        For j = 1 To maxLag
            t(j, k) = 0
        Next
    Next

    t(0, 0) = 1
    t(1, 1) = p(1)
    For k = 2 To maxLag
        'Calculate factors to take away from p(i)'
        totalt = 0
        For j = 1 To k - 1
            If k - 1 <> j And k - 2 > 0 Then
                t(k - 1, j) = t(k - 2, j) - t(k - 1, k - 1) * t(k - 2, k - 1 - j)
            End If
            totalt = totalt + t(k - 1, j) * p(k - j)
        Next
        t(k, k) = (p(k) - totalt) / (1 - totalt)
        
    Next
    
    For k = 1 To numLags
        If vertOutput Then
            output(k, 1) = t(lags(k), lags(k))
        Else
            output(1, k) = t(lags(k), lags(k))
        End If
    Next
    
    PAutoCor = output
    
End Function

Conclusion

I've added this function to my add-in which can be found on Sourceforge. Version 0.6.12 contains this macro.

As ever, all comments are welcome.

ONS UK Visitor Numbers

This is just a quick note to say that I've written an article about the UK visitor numbers released by the ONS last December.

I haven't put it here as I can't seem to get the D3 library to work nicely with blogger. I'm not sure yet what I'm doing wrong.

Anyway, it's on my new website at http://www.surveyscience.co.uk/articles_ONS.html.

D3 - Simple Line Chart

There seem to be a lot of tutorials on the web about D3 (www.d3js.org). However I've yet to find one that explains,simply, how to create a line chart. They all seem to be overly complicated, don't explain exactly what is happening, or call functions, classes and variables by the same name.

So here's my attempt. It took me a good few hours to get this working, which is pretty poor given that what I achieved is extremely simple.

Interactive Excel Maps - part 2

Last time I detailed the classes needed for the maps. This time I'll show the code I used to create the maps.

The first thing we need to do is create a new module and set up some global variables. A dictionary object to hold a reference to the map object and ensure that the memory used by it doesn't get collected. A variable to hold the count of maps and a MapEvent object that will switch on and off events when switching sheets and books etc.

Public mcd As New Dictionary
Public mcCount As Integer
Dim clsMapEvent As New MapEvent

The next step is to create the subroutines that will enable and disable the map events. These subroutines are called from the MapEvent class.

Sub Set_All_Maps()
    Dim mc1 As New MapChart
    Dim cs As New VBA.Collection
    Dim chtNumber As Integer
    
    ' Will not work or enable events for active sheet if sheet is a chart sheet'
 
    ' Enable events for all charts embedded on a sheet'
    ' Works for embedded charts on a worksheet or chart sheet'
    If ActiveSheet.ChartObjects.Count > 0 Then
        Dim chtObj As ChartObject
        Dim chtnum As Integer
        Dim sp As Shape
 
        chtnum = 1
        For Each chtObj In ActiveSheet.ChartObjects
            If Left(chtObj.name, 3) = "Map" Then
                Set mc1.MapChart = chtObj.Chart
                Set mc1.srcDataRange = range(Cells(2, 1), Cells(2, 2)).CurrentRegion
                For Each sp In chtObj.Chart.Shapes
                    cs.Add sp
                Next
                Set mc1.reg_shapes = cs
                If Len(chtObj.name) > 3 Then
                    chtNumber = CInt(Mid(chtObj.name, 5, Len(chtObj.name) - 4))
                    mc1.SetScaleLow Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 4).Value, Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 5).Value, Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 6).Value
                    mc1.SetScaleHigh Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 7).Value, Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 8).Value, Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(chtNumber, 9).Value
                End If
                mcd.Add mcd.Count + 1, mc1
            End If
        Next
    End If
End Sub
 
Sub Reset_All_Maps()
    ' Disable events for all charts previously enabled'
    Dim chtnum As Integer
    
    On Error Resume Next
    
    For chtnum = 1 To mcd.Count
        Set mcd.Item(chtnum).MapChart = Nothing
    Next
    mcd.RemoveAll
End Sub

Some things need explaining in the above code. Firstly this is all run from an add-in I've called surveyscience.xlam (available here, if you're interested). It contains a sheet called MapSheet that holds details of the maps that I've defined. This is used to update the properties of the map chart. Also, this will only work for embedded charts. Adding code for this should be fairly simple though. I didn't bother as I was using the maps for a dashboard.

The Map Routine

Finally, we need to define the subroutine to create the actual map. This happens in two stages. The first stage loads the map definition to memory, creating the region and region_bit objects along the way. The map created by this macro is based on the details held in the MapSheet worksheet. The variable mapRow passed to the subroutine is used to look up the details from MapSheet.

The second part creates the chart object and draws the map over the chart. The macro is fairly long unfortunately.

Private Sub CreateMap(mapRow As Integer)
    'Maps'
    Dim sdr As range        'Source data range'
    Dim mc1 As New MapChart 'New map chart'
    Dim co As Shape         'Base for map'
    
    'Maxs and mins of map data'
    Dim minX As Double
    Dim minY As Double
    Dim maxX As Double
    Dim maxY As Double

    minX = 1E+200
    minY = 1E+200
    maxX = -1E+200
    maxY = -1E+200
    
    'Load file'
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim fileNum As Integer
    Dim mapFSO As FileSystemObject
    Dim mapFile
    Dim LineText As String
    Dim arr
    Dim header
    Dim regName As String
    Dim typ As String
    Dim mapRegs As New VBA.Collection
    Dim temp_reg As Region
    Dim temp_bit As Region_Bit
    Dim temp_point As MapPoint2D
    Dim temp_coord
    Dim defStr1 As String
    Dim wk As Worksheet
    Dim mapRange As range
    
    'Add workbook if none exists'
    If Workbooks.Count = 0 Then
        Workbooks.Add
    End If
    
    'Add worksheet'
    Set wk = Worksheets.Add

    'Get path of map'
    Set mapRange = Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(1, 1).CurrentRegion
    Set mapRange = range(mapRange(mapRow, 1), mapRange(mapRow, 9))
    defStr1 = Workbooks("surveyScience.xlam").Worksheets("MapSheet").Cells(mapRow, 2).Text
    
    Set mapFSO = CreateObject("Scripting.FileSystemObject")
    Set mapFile = mapFSO.OpenTextFile(defStr1, 1, False, -1)
    
    'Extract data from file'
    Do While mapFile.AtEndOfStream <> True
        LineText = mapFile.ReadLine
        arr = Split(LineText, ";")
        header = Split(arr(0), ",")
        regName = header(5)
        wk.Cells(mapRegs.Count + 2, 1) = regName
        Set temp_reg = New Region
        temp_reg.setName (regName)
        temp_reg.setColour CInt(header(1)), CInt(header(2)), CInt(header(3))
        If header(0) = "f" Then
            temp_reg.setFill (True)
        Else
            temp_reg.setFill (False)
        End If
            
        arr = Split(arr(1), " ")
        For i = 0 To UBound(arr)
            If arr(i) = "M" Then
                Set temp_bit = New Region_Bit
                typ = "M"
            ElseIf arr(i) = "L" Then
                typ = "L"
            ElseIf arr(i) = "z" Then
                typ = "z"
                temp_reg.addBit temp_bit
                Set temp_bit = Nothing
            Else
                'Split point into x,y'
                temp_coord = Split(arr(i), ",")
                Set temp_point = New MapPoint2D
                temp_point.SetX (temp_coord(0))
                temp_point.SetY (temp_coord(1))
                If typ = "M" Then
                    temp_bit.setStartPoint temp_point
                ElseIf typ = "L" Then
                    temp_bit.addPoint temp_point
                End If
                    
                'Set mins and maxs'
                If temp_coord(0) > maxX Then maxX = temp_coord(0)
                If temp_coord(1) > maxY Then maxY = temp_coord(1)
                If temp_coord(0) < minX Then minX = temp_coord(0)
                If temp_coord(1) < minY Then minY = temp_coord(1)
                    
                Set temp_point = Nothing
            End If
        Next
            
        mapRegs.Add temp_reg
        Set temp_reg = Nothing
    Loop
    mapFile.Close
    
    'Create chart'
    Set co = wk.Shapes.AddChart
    co.Select
    
    'Increase size of chart by 20%'
    co.width = co.width * 1.2
    co.Height = co.Height * 1.2
    
    'Change name so that we can identify chart as a map'
    ActiveChart.Parent.name = "Map_" & mapRow
    
    'Assign active charts as map chart'
    Set mc1.MapChart = ActiveChart
    Set sdr = wk.range(Cells(2, 1), Cells(mapRegs.Count + 1, 2))
    Set mc1.srcDataRange = sdr
    Call mc1.SetScaleLow(mapRange.Cells(1, 4).Value, mapRange.Cells(1, 5).Value, mapRange.Cells(1, 6).Value)
    Call mc1.SetScaleHigh(mapRange.Cells(1, 7).Value, mapRange.Cells(1, 8).Value, mapRange.Cells(1, 9).Value)
    'Set properties of chart'
    ActiveChart.SetSourceData Source:=sdr
    ActiveChart.ChartType = xlColumnClustered
    ActiveChart.PlotBy = xlColumns
    ActiveChart.Legend.Delete
    ActiveChart.HasTitle = False
    ActiveChart.Axes(xlValue).Delete
    ActiveChart.Axes(xlCategory).Delete
    ActiveChart.Axes(xlValue).MajorGridlines.Delete
    
    'Maxs and mins of plot area'
    Dim x1 As Double
    Dim y1 As Double
    Dim x2 As Double
    Dim y2 As Double
    x1 = ActiveChart.PlotArea.Left
    y1 = ActiveChart.PlotArea.Top
    x2 = ActiveChart.PlotArea.Left + ActiveChart.PlotArea.width
    y2 = ActiveChart.PlotArea.Top + ActiveChart.PlotArea.Height
    
    'Background'
    'Chart Area background'
    With ActiveChart.Shapes.BuildFreeform(msoEditingAuto, -6, -6)
        .AddNodes msoSegmentLine, msoEditingAuto, -6, ActiveChart.ChartArea.Height
        .AddNodes msoSegmentLine, msoEditingAuto, ActiveChart.ChartArea.width, ActiveChart.ChartArea.Height
        .AddNodes msoSegmentLine, msoEditingAuto, ActiveChart.ChartArea.width, -6
        .AddNodes msoSegmentLine, msoEditingAuto, -6, -6
        .ConvertToShape.name = "Background"
    End With
    
    'Calculate scaling factors'
    Dim mx As Double
    Dim cx As Double
    Dim my As Double
    Dim cy As Double
    Dim dA As Double
    Dim rA As Double
    Dim ex As Double
    
    mx = (x2 - x1) / (maxX - minX)
    my = (y2 - y1) / (maxY - minY)
    cx = x1 - mx * minX
    cy = y1 - my * minY
    
    'Keep aspect the same'
    dA = Abs((y2 - y1) / (x2 - x1))
    rA = Abs((maxY - minY) / (maxX - minX))
    If (dA > rA) Then
        ex = (maxY - minY) * (dA / rA - 1)
        mx = (x2 - x1) / (maxX - minX)
        my = (y2 - y1) / ((maxY + ex / 2) - (minY - ex / 2))
        cx = x1 - mx * minX
        cy = y1 - my * (minY - ex / 2)
    ElseIf (dA < rA) Then
        ex = (maxX - minX) * (rA / dA - 1)
        mx = (x2 - x1) / ((maxX + ex / 2) - (minX - ex / 2))
        my = (y2 - y1) / (maxY - minY)
        cx = x1 - mx * (minX - ex / 2)
        cy = y1 - my * minY
    Else
        mx = 1
        my = 1
        cx = 0
        cy = 0
    End If
    
    'Draw parts of map'
    Dim reg_shape
    Dim t As Shape
    Dim rs As New VBA.Collection
    
    'Cycle through regions'
    For i = 1 To mapRegs.Count
        'Cycle through bits'
        For j = 1 To mapRegs.Item(i).getNumBits
            Set temp_bit = mapRegs.Item(i).getBit(j)
            'Create new shape'
            Set reg_shape = ActiveChart.Shapes.BuildFreeform(msoEditingAuto, temp_bit.getStartPoint().GetX() * mx + cx, temp_bit.getStartPoint().GetY() * my + cy)
            'Cycle through points'
            For k = 1 To mapRegs.Item(i).getBit(j).getNumPoints
                'Add point to shape'
                reg_shape.AddNodes msoSegmentLine, msoEditingAuto, temp_bit.getPoint(k).GetX() * mx + cx, temp_bit.getPoint(k).GetY() * my + cy
            Next
            'Convert to shape'
            If mapRegs.Item(i).getFill() = True Then
                Set t = reg_shape.ConvertToShape
                With t
                    .name = mapRegs.Item(i).getName
                    .fill.ForeColor.RGB = mapRegs.Item(i).getColour2()
                    .Line.ForeColor.RGB = RGB(0, 0, 0)
                    .Line.Weight = 0.25
                    
                End With
                rs.Add t
            End If
            
            Set reg_shape = Nothing
        Next
    Next
    
    Set mc1.reg_shapes = rs
    mcCount = mcCount + 1
    mcd.Add mcCount, mc1
End Sub

Conclusion

And there it is, a way to create reasonable and extensible maps in Excel.

Presumably you could combine the two parts of the macro and create the shapes directly from the file. It might be easier. However, splitting the code makes it easier to change the subroutine to load in different map formats.

One limitation that I've found in Excel 2013 is that the shapes seem to default to a mitre join. This makes the maps look horrendous. There is no way to programmatically change the joins to round. You have to manually create a shape, change the join type, set the shape as the default type and then run the macro. Odd.

As usual, comments are welcome.

Interactive Excel Maps - part 1

Introduction

I've recently been trying to get some interactive maps working in Excel for a dashboard we were using at work.

What follows is the first part of an explanation of how I did it and an example of what it looks like.

Of course I could have created the maps much more simply in R or Quantum GIS but that wouldn't have helped for the dashboard.

Market Research and Statistics Excel add-in Part 2

I've removed the password protection from my add-in and it's now on version 0.6.

It's in the same place on www.surveyscience.co.uk