A rather accurate VBA stopwatch

Question

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.

Answer 1

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.

• Greedo: 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.
• Greedo: 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.
• Greedo: 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
• Raystafarian: 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.