3
\$\begingroup\$

Intro

Related, related

I'm trying to come up with a neat, accurate way of timing VBA code, as I'm yet to find a method to do this in VBA directly (without plugins etc.)

The general idea was to create some Stopwatch class which could be initialised at the start of a test procedure, then various markers could be dotted throughout the code under review and when execution reaches these markers, the stopwatch class makes a note of the time.

To get an in-depth profile of code execution, I wanted to be able to differentiate between Main methods and Sub methods (ie if Sub Foo calls Sub A and Sub B, it would be nice to have stats for Foo, and beneath it, A and B individually). Another LabelTree class could be used to build up this hierarchy model.

Finally a StopwatchResults class can hold methods required to turn raw timestamp data (held in TimeInfo classes) into execution times for different methods, and return that info in required formats (currently just printing or as a LabelTree object).

Put that all together and you can write something like this:

Sub testRoutine()
    Dim ck As New Stopwatch
    ck.Start
        ck.OpenLabel "HeavyWork"
            DoSomeHeavyWork
        ck.CloseLabel
        ck.OpenLabel "LoopTest"
            Dim i As Long
            For i = 1 To 5
                DoSomeHeavyWork 0.1
                ck.Lap
            Next i
        ck.CloseLabel
    ck.Finish
    ck.Results.ToImmediateWindow
End Sub

Which prints for example:

Label name    Time taken
-----------------------------------
1 Start        1.00116134128621            1.90410726645496E-03 
1.1 HeavyWork  0.500211852449866           2.6879100187216E-04 
1.2 LoopTest   0.500682749669068           1.43936557287816E-03 
1.2.1 Lap1     0.100088742066873           2.34935650951229E-04 
1.2.2 Lap2     0.100127727018844           2.38013410125859E-04 
1.2.3 Lap3     0.100125675184245           2.53402205999009E-04 
1.2.4 Lap4     0.100125675184245           2.53402205999009E-04 
1.2.5 Lap5     0.10012362334237            2.50324446824379E-04 

NB. DoSomeHeavyWork here was just a pause of length seconds

Sub DoSomeHeavyWork(Optional length As Single = 0.5)
    Dim startTime As Single
    startTime = Timer
    Do Until Timer - startTime > length
        'DoEvents
    Loop
End Sub

Labels

You can see how the test code makes use of labels to enclose portions of the code. Think of labels like brackets, you can OpenLabel and CloseLabel and partition the code into sections like that, the stopwatch measures time between the brackets.

.Start and .Finish are just labels with default name, equivalent to .OpenLabel("Start") and .CloseLabel respectively.

.Lap is a special kind of label. Rather than needing to open and close, laps are used to characterise loops. They measure time relative to the previous label (be it an openLabel/Start or another Laplabel)

Nested labels are considered child nodes in the tree of hierarchy, so "HeavyWork" is a child of the "Start" label. Lap labels are special and can't have child nodes; i.e. you can't make a sub label within a lap measurement (behaviour which I may change, but can be worked around by using a normal label instead)

With this bracket model the code becomes (Laps open and close their own brackets, except Lap1)

Start(
    HeavyWork(
    )
    LoopTest(
         Lap1)
         (Lap2)
         (Lap3)
         (Lap4)
         (Lap5)
    )
)

How the timing works

The idea was to ensure that the time recorded for a given run was independent of the presence of the stopwatch class. For that reason whenever the class is accessed, it mesures a time-in and a time-out (i.e., it times anything it does between receiving control and handing it back to the caller). This time is subtracted from overall execution time to reduce the impact of of the class on timing results.

The time registered on a label is therefore:

(Time into close label) - (Time out of open label) - (Time wasted by stopwatch class in all child nodes)

Implementation

To add all of these modules to a project at once, add and run the extract method of this compressed file. You'll need to allow programmatic access to the project

Stopwatch class

Class to generate label tree hierarchy (Start,OpenLabel,CloseLabel,Lap,Finish), and calculate timestamps (MicroTimer) at each label. These are stored in a dictionary using keys based on the location of a label within the tree

Option Explicit

Private Type TStopWatch
    data As Object
    CurrentLabel As LabelTree
    Results As StopwatchResults
    FirstLabel As LabelTree
End Type

Private this As TStopWatch

Private Declare PtrSafe Function getFrequency Lib "kernel32" _
Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare PtrSafe Function getTickCount Lib "kernel32" _
Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long

Private Function MicroTimer() As Double
    'Accurate timing method - stackoverflow.com/a/7116928/6609896
    Dim cyTicks1 As Currency
    Static cyFrequency As Currency

    MicroTimer = 0

    If cyFrequency = 0 Then getFrequency cyFrequency

    getTickCount cyTicks1

    If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency
End Function

Public Sub Start()
    OpenLabel "Start"
End Sub

Public Sub Finish()
    CloseLabel
    Set this.Results = New StopwatchResults
    this.Results.LoadData this.data, this.FirstLabel
End Sub

Public Property Get Results() As StopwatchResults
    Set Results = this.Results
End Property

Public Sub OpenLabel(ByVal labelName As String)
    'Save time on arrival
    Dim clockTimes As New TimeInfo
    clockTimes.TimeIn = MicroTimer

    'Define new label, and make it a child of the current label
    Dim newNode As New LabelTree
    newNode.NodeName = labelName
    If Not this.CurrentLabel Is Nothing Then
        Set newNode.parentNode = this.CurrentLabel
        '1.2.1 format
        newNode.Location = this.CurrentLabel.Location & "." & this.CurrentLabel.ChildNodes.Count + 1
        this.CurrentLabel.ChildNodes.Add newNode, newNode.Location & newNode.NodeName
    Else
        newNode.Location = "1"
        Set this.FirstLabel = newNode
    End If
    Set this.CurrentLabel = newNode

    'Save time data to dictionary and return to execution
    Dim dictKey As String
    dictKey = newNode.Location & "_open"
    this.data.Add dictKey, clockTimes
    this.data(dictKey).TimeOut = MicroTimer
End Sub

Public Sub CloseLabel()
    'Save time on arrival
    Dim clockTimes As New TimeInfo
    clockTimes.TimeIn = MicroTimer

    'Save time data to dictionary and return to execution
    Dim dictKey As String
    dictKey = this.CurrentLabel.Location & "_close"
    this.data.Add dictKey, clockTimes

    'Close label by setting to parent
    Set this.CurrentLabel = this.CurrentLabel.parentNode
    this.data(dictKey).TimeOut = MicroTimer
End Sub

Public Sub Lap()
    'Save time on arrival
    Dim clockTimes As New TimeInfo
    clockTimes.TimeIn = MicroTimer

    'Define new label, and make it a child of the current label
    Dim newNode As New LabelTree
    newNode.Location = this.CurrentLabel.Location & "." & this.CurrentLabel.ChildNodes.Count + 1
    newNode.NodeName = "Lap" & this.CurrentLabel.ChildNodes.Count + 1 'this.CurrentLabel.NodeName & "_
    newNode.LabelType = stp_LapTime

    If this.CurrentLabel Is Nothing Then
        Err.Description = "No test is currently running to write lap data to"
        Err.Raise 5
    Else
        Set newNode.parentNode = this.CurrentLabel
        this.CurrentLabel.ChildNodes.Add newNode, newNode.NodeName
    End If


    'Save time data to dictionary and return to execution
    Dim dictKey As String
    dictKey = this.CurrentLabel.Location & "_" & newNode.NodeName
    this.data.Add dictKey, clockTimes
    this.data(dictKey).TimeOut = MicroTimer
End Sub

Private Sub Class_Initialize()
    Set this.data = CreateObject("Scripting.Dictionary")
End Sub

LabelTree Class

Each instance of a LabelTree object represents a node. Nodes are arranged in a tree fashion, with parent nodes and child nodes (equivalent to level of nesting of labels). The Enum facilitates different post-processing logic for lap labels vs everything else.

Option Explicit

Public Enum stopwatchLableType
    stp_LapTime = 1
    stp_Label
    stp_Start
    stp_Finish
End Enum

Private Type TLabelTree
    parentNode As LabelTree
    ChildNodes As Collection
    NodeName As String
    TimeSpent As Double
    TimeWasted As Double                         'time used by stopwatch runs
    Location As String
    LabelType As stopwatchLableType
End Type

Private this As TLabelTree
Public Property Get LabelType() As stopwatchLableType
    LabelType = this.LabelType
End Property

Public Property Let LabelType(ByVal value As stopwatchLableType)
    this.LabelType = value
End Property

Public Property Get Location() As String
    Location = this.Location
End Property

Public Property Let Location(ByVal value As String)
    this.Location = value
End Property

Public Property Get TimeSpent() As Double
    TimeSpent = this.TimeSpent
End Property

Public Property Let TimeSpent(ByVal value As Double)
    this.TimeSpent = value
End Property

Public Property Get TimeWasted() As Double
    TimeWasted = this.TimeWasted
End Property

Public Property Let TimeWasted(ByVal value As Double)
    this.TimeWasted = value
End Property

Public Property Get ChildNodes() As Collection
    Set ChildNodes = this.ChildNodes
End Property

Public Property Set ChildNodes(ByVal value As Collection)
    Set this.ChildNodes = value
End Property

Public Property Get NodeName() As String
    NodeName = this.NodeName
End Property

Public Property Let NodeName(ByVal value As String)
    this.NodeName = value
End Property

Public Property Get parentNode() As LabelTree
    Set parentNode = this.parentNode
End Property

Public Property Set parentNode(ByVal value As LabelTree)
    Set this.parentNode = value
End Property

Private Sub Class_Initialize()
    Set this.ChildNodes = New Collection
End Sub

TimeInfo Class

Holds a timestamp. The only reason this is a Class and not a Type is because it has to be added to a dictionary.

Option Explicit

Private Type TTimeInfo
    TimeIn As Double
    TimeOut As Double
End Type

Private this As TTimeInfo

Public Property Get TimeIn() As Double
    TimeIn = this.TimeIn
End Property

Public Property Let TimeIn(ByVal value As Double)
    this.TimeIn = value
End Property

Public Property Get TimeOut() As Double
    TimeOut = this.TimeOut
End Property

Public Property Let TimeOut(ByVal value As Double)
    this.TimeOut = value
End Property

StopwatchResults Class

This class does all the post-processing of the labelTree. It converts raw timestamps into time differences using the logic outlined earlier. It also contains methods to output data. The exact implementation here is likely to change a lot - as I intend to expand the output formats to include .ToFile and .ToSheet. Also there may be some statistics built in for loops.

Option Explicit

Private Type TStopWatchResults
    TimeData As Object
    LabelData As LabelTree
End Type

Private this As TStopWatchResults

Public Sub LoadData(ByVal TimeData As Object, ByVal LabelData As LabelTree)
    Set this.LabelData = LabelData
    Set this.TimeData = TimeData
    writeTimes this.LabelData
End Sub

Public Property Get ToLabelTree() As LabelTree
    Set ToLabelTree = this.LabelData
End Property

Public Property Get RawData() As Object
    Set RawData = this.TimeData
End Property

Public Sub ToImmediateWindow()
'Prints time info to immediate window
    Dim resultsTree As LabelTree
    Set resultsTree = this.LabelData
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    flattenTree resultsTree, dict
    Debug.Print "Label name", "Time taken"
    Debug.Print String(35, "-")
    Dim value As Variant
    For Each value In dict.Keys
        Debug.Print value, dict(value)(0), dict(value)(1)
    Next value
End Sub

Private Sub flattenTree(ByVal treeItem As LabelTree, ByRef dict As Object, Optional ByVal depth As Long = 0)
'recursively converts a results tree to a dictionary of result keys
    dict.Add printf("{0} {1}", treeItem.Location, treeItem.NodeName), Array(treeItem.TimeSpent, treeItem.TimeWasted)
    If treeItem.ChildNodes.Count > 0 Then
        Dim item As Variant
        For Each item In treeItem.ChildNodes
            flattenTree item, dict, depth + 1
        Next
    End If
End Sub

Private Sub writeTimes(ByRef labelItem As LabelTree)
    'Recursively write absolute time data to time elapsed data

    Dim startTimes As TimeInfo
    Dim endTimes As TimeInfo

    setTimeStamps labelItem, startTimes, endTimes 'get timestamps from dictionary
    With labelItem
        If .ChildNodes.Count > 0 Then
            'has children, work out time spent for each then sum
            Dim childLabel As LabelTree
            Dim item As Variant

            For Each item In .ChildNodes         'recurse deeper
                Set childLabel = item
                writeTimes childLabel
                .TimeWasted = .TimeWasted + childLabel.TimeWasted 'add up child wasted time
            Next item
            .TimeSpent = endTimes.TimeIn - startTimes.TimeOut - .TimeWasted 'time diff - wasted time
            .TimeWasted = .TimeWasted + endTimes.TimeOut - endTimes.TimeIn + startTimes.TimeOut - startTimes.TimeIn
        Else                                     'No children
            If .LabelType = stp_LapTime Then
                .TimeWasted = endTimes.TimeOut - endTimes.TimeIn
            Else                                 'find time stamps for opening and closing label
                .TimeWasted = endTimes.TimeOut - endTimes.TimeIn + startTimes.TimeOut - startTimes.TimeIn
            End If
            .TimeSpent = endTimes.TimeIn - startTimes.TimeOut
        End If
    End With
End Sub

Private Sub setTimeStamps(ByVal labelItem As LabelTree, ByRef startTimes As TimeInfo, ByRef endTimes As TimeInfo)
    'writes timestamps byref
    With labelItem
        Dim startKey As String
        Dim endKey As String
        'location of timestamps in dictionary
        Select Case .LabelType
        Case stp_LapTime
            Dim keyBase As String
            keyBase = .parentNode.Location
            Dim lapNumber As Long
            lapNumber = Right$(.NodeName, Len(.NodeName) - 3)
            If lapNumber = 1 Then                'first lap, starts at
                startKey = printf("{0}_open", keyBase)
            Else
                startKey = printf("{0}_Lap{1}", keyBase, lapNumber - 1) 'start at prev lap, end here
            End If
            endKey = printf("{0}_Lap{1}", keyBase, lapNumber)
        Case Else
            startKey = printf("{0}_open", .Location)
            endKey = printf("{0}_close", .Location)
        End Select
        Set endTimes = this.TimeData(endKey)
        Set startTimes = this.TimeData(startKey)
    End With

End Sub

Private Function printf(ByVal mask As String, ParamArray tokens()) As String
'Format string with by substituting into mask - stackoverflow.com/a/17233834/6609896
    Dim i As Long
    For i = 0 To UBound(tokens)
        mask = Replace$(mask, "{" & i & "}", tokens(i))
    Next
    printf = mask
End Function

My concerns

I would particularly like feedback on a few things:

  • Comments and names; I feel like comments are sparse, but maybe naming has made up for those ambiguities?
  • User Interface; particularly Labels
    • Is there a better name for open and close label to make it obvious what they do?
    • How about Laps, do they make sense?
    • I could have auto-closed all labels like I did with laps, would this have been cleaner? It would give less control over precisely which portions of code are measured.
  • ACCURACY. This is a major concern. I've tried to put everything the class does between 2 MicroTimers, so that class overhead can be subtracted from overall measured time. I ran some tests for loops under different conditions (fixed number of loops, sometimes calling routines in the loop, sometimes measuring time for individual loops) to compare my Stopwatch vs writing MicroTimer to a pre-dimensioned array. These are the results:

Results

Which are a bit cryptic. But essentially it compares Real - MicroTimer+Array times (overall and per lap) to Ck - Stopwatch times. And it shows that when the overhead of the class (Waste) is of the same order of magnitude as the running time for the test, the measurements for stopwatch are about 3-4 times longer than the Real measurements. This means that timings below a precision of 1E-4 ~ 100us are fairly inaccurate.

Can anyone see how to improve the accuracy?

Obviously any and all other feedback is welcome too.

\$\endgroup\$
1
\$\begingroup\$

I don't know how useful this review will be as a review, but I want to write it up anyway.


Re:

  • How about Laps, do they make sense?
  • I could have auto-closed all labels like I did with laps, would this have been cleaner? It would give less control over precisely which portions of code are measured.

The way you handle the Lap appears to make it impossible for a Lap node to have a child node. If you put any labels inside a Lap, the stopwatch doesn't add a node to the Lap node, it just adds another node to the Start node.

I haven't quite figured out exactly what is happening, I just know at a certain point in setTimeStamps (recursed down) the startKey that it's looking for to set startTimes doesn't exist. I think I'm in over my head, I'll try some pictures -

Here it looks for 1Lap_2

enter image description here

But here you'll see that doesn't exist, it went from Lap1 to Lap3

enter image description here


The code that did this is

Option Explicit

Sub test()
    Dim clock As New Stopwatch
    clock.Start
    Dim i As Long
    For i = 1 To 10
        clock.Lap
        testMe clock, "label " & i
    Next
    clock.Finish
    clock.Results.ToImmediateWindow
End Sub

Sub testMe(ByRef clock As Stopwatch, ByVal label As String)
    clock.OpenLabel label
    'clock.Lap
    SaySomething label
    clock.CloseLabel
End Sub

Sub SaySomething(ByVal label As String)
    MsgBox label
End Sub

If you remove the Clock.Lap in the For loop and un-comment the Clock.Lap in TestMe it works fine.

I was just passing the clock around some procedures, but this will occur in a very simple setup as well -

Sub Test2()
    Dim clock As New Stopwatch
    clock.Start
    Dim i As Long
    For i = 1 To 3
        clock.Lap
        clock.OpenLabel i
        MsgBox i
        clock.CloseLabel
    Next
    clock.Finish
End Sub

And the error occurs on the Clock.Finish.

Oh, and that extract method is nearly the coolest thing I've seen in VBA.

\$\endgroup\$
  • \$\begingroup\$ Good spot. It's true that lap labels don't support child nodes. That's because their non standard format makes it a little more complicated to determine which nodes are children and which are siblings. But I think they're a little pointless if I don't add this behaviour in? Either way the workaround is to have an open and close pair in the loop instead. I also notice you put lap at the start of the loop - lap measurements are currently relative to the previous label (the lap ends when you hit the lap label) - I imagine a coach with a stopwatch can tell you the lap time only at the end. \$\endgroup\$ – Greedo May 22 '18 at 10:12
  • \$\begingroup\$ But perhaps measuring relative to the next label (putting lap at the start of the loop) is more intuitive - as you have naturally done. What do you think? I envisage a public stopwatch, perhaps predeclared (default instance attribute) and in personal.xlsb to avoid all the passing around. But then a reset method would be necessary. \$\endgroup\$ – Greedo May 22 '18 at 10:17
  • \$\begingroup\$ PS thanks, the code for compressing projects into a single module seems to be working well, although it won't work with userforms yet. Still early bound and very ugly, but it's next on my list of stuff to finish and maybe post here for a review ;-) I gotta say I think it's pretty swanky \$\endgroup\$ – Greedo May 22 '18 at 10:22
  • \$\begingroup\$ Right, I'm not sure how else the Lap would make sense, I think it's more of an error catching case. I think lap does make sense at the beginning of the loop, like a start lap since your lap didn't start on start. \$\endgroup\$ – Raystafarian May 23 '18 at 23:51

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.