Coding Decision Trees in VBA

Question

I have created a function in VBA as follows:

Private Enum gridInstruction 'in the class declarations section
 Place_Break 'not enumerated to anything specific, so uses default 0,1,2...
 Place_Chain
 Place_Chain_Flag
 Skip
End Enum
Private Function applyRules(ByVal imgGrid As Collection) As gridInstruction 'applies rules to imggrid based on input values
 Dim step1 As Boolean
 Dim step2 As Byte
 Dim step3 As Byte
 step1 = (imgGrid("B2").Left = 0)
 If firstCol Then
 step2 = bestChain("b2", imgGrid)
 Select Case step2
 Case 1
 applyRules = Place_Chain
 Case 2
 step3 = chainedBy("C2", imgGrid)
 Select Case step3
 Case 1
 applyRules = Skip
 Case 2
 applyRules = Place_Chain
 Case 3
 applyRules = Place_Chain
 End Select
 Case 3
 step3 = chainedBy("C3", imgGrid)
 Select Case step3
 Case 1
 applyRules = Skip
 Case 2
 applyRules = Skip
 Case 3
 applyRules = Place_Chain
 End Select
 End Select
 Else
 step2 = chainedBy("b2", imgGrid)
 Select Case step2
 Case 1
 applyRules = Place_Break
 Case 2
 step3 = bestChain("A2", imgGrid)
 Select Case step3
 Case 1
 applyRules = Place_Break
 Case 2
 applyRules = Place_Chain
 Case 3
 applyRules = Place_Chain_Flag 'set chain flag to come back here when chain next breaks
 End Select
 Case 3
 step3 = bestChain("A3", imgGrid)
 Select Case step3
 Case 1
 applyRules = Skip
 Case 2
 applyRules = Skip
 Case 3
 applyRules = Place_Chain
 End Select
 End Select
 End If
End Function

Which references 2 additional functions:

Private Function bestChain(imgAddress As String, gridVals As Collection) As Byte

And

Private Function chainedBy(imgAddress As String, gridVals As Collection) As Byte

which return an integer 1-3, stored as a Byte (almost certainly premature optimisation, but I don't find it any less readable than say Integer or Long)

This function can be summarised with a tree structure like this:

Decision Tree

In case it's not clear: Green Ovals are tests, Blue Arrows are the results from those tests, Orange Boxes are the return values of the function. None of the tests are identical so I don't think there's any other way of structuring that decision tree (correct me if I'm wrong)

But when I try to put this in code, it ends up messy; I worry that all of the Select Cases and If statements are going to be hard to read and maintain.

Is there a better way of structuring this code (and anything else worth highlighting)? NB. this function is called many times so I'm hoping to keep it as streamlined as possible - so any solutions which require many more variables to be assigned might be detrimental to the running time.

Additional functions

The 2 additional functions referenced here are:

Private Function bestChain(imgAddress As String, gridVals As Collection) As Byte
 Dim toparray(1 To 3) As Long
 Dim imgX As Long 'column number
 Dim imgY As Long 'rownum
 Dim imgIndex As Long
 Dim nTop As Long, nMid As Long, nBot As Long, testImg As Long 'values of the tops of all images
 Dim nTop_img As clsImg
 
 imgX = Range(imgAddress).Column 'use range notation so address can be accessed with worksheet functions
 imgY = Range(imgAddress).Row
 imgIndex = (imgY - 1) * 3 + imgX '3 * (rownum-1) + column
 
 Set nTop_img = gridVals(imgIndex - 2) ' -1 row +1 col
 testImg = gridVals(imgIndex).Top
 nMid = gridVals(imgIndex + 1).Top ' +1 col
 nBot = gridVals(imgIndex + 4).Top ' +1 row +1 col
 If nTop_img Is Nothing Then
 toparray(1) = -1 'flag as invalid
 Else
 toparray(1) = Abs(testImg - nTop_img.Top)
 End If
 toparray(2) = Abs(testImg - nMid) ' abs distance in y between tops
 toparray(3) = Abs(testImg - nBot)
 bestChain = posArrMin(toparray)(1) 'index of best match
End Function

And

Private Function chainedBy(imgAddress As String, gridVals As Collection) As Byte
 Dim toparray(1 To 3) As Long
 Dim imgX As Long 'column number
 Dim imgY As Long 'rownum
 Dim imgIndex As Long
 Dim pMid As Long, pBot As Long, testImg As Long 'values of the tops of all images in prev column
 Dim pTop_img As clsImg
 
 imgX = Range(imgAddress).Column 'use range notation so address can be accessed with worksheet functions
 imgY = Range(imgAddress).Row
 imgIndex = (imgY - 1) * 3 + imgX '3 * (rownum-1) + column
 
 Set pTop_img = gridVals(imgIndex - 4) '-1 row - 1 col
 testImg = gridVals(imgIndex).Top
 pMid = gridVals(imgIndex - 1).Top ' -1 col
 pBot = gridVals(imgIndex + 2).Top ' +1 row -1 col
 If pTop_img Is Nothing Then
 toparray(1) = -1 'flag as invalid
 Else
 toparray(1) = Abs(testImg - pTop_img.Top)
 End If
 toparray(2) = Abs(testImg - pMid) ' abs distance in y between tops
 toparray(3) = Abs(testImg - pBot)
 chainedBy = posArrMin(toparray)(1) 'index of best match
End Function

Which is the same as BestChain except that it references some slightly different elements of the collection.

The collection (and both functions assume this) is always 9 items in size, which represent a 3x3 grid, where each item in the collection has an [A1] style key. I.e. item 3 has the key "C1", item 8 is "B3". Each item is of clsImage type, a custom class I have declared, but for the purposes of this code can be treated as:

Type clsImg
 Top As Long
 Left As Long
 Width As Long
 Height As Long
End Type

The values in the top row (collection items 1-3) may be Nothing.

Finally, those 2 functions both reference a third function:

Private Function posArrMin(arr() As Long) As Long() 'function to return min value of positive array and its index
 '-ve values skipped
 'assumes at least 1 non negative value
 Dim minVal As Long 'minimum value in array
 Dim thisVal As Long 'value to be checked
 Dim i As Long 'iterator
 Dim minI As Long 'index of smallest value
 Dim Results(1 To 2) As Long
 minVal = -1
 For i = LBound(arr) To UBound(arr)
 thisVal = arr(i)
 If thisVal >= 0 Then 'otherwise skip
 If thisVal < minVal Or minVal = -1 Then 'new min or min needs to be set
 minVal = thisVal
 minI = i
 End If
 End If
 Next i
 Results(1) = minI
 Results(2) = minVal
 posArrMin = Results 'index, value
End Function

Which returns a slightly unusual Long(1 To 2) array - and only the first item is ever used in the bestChain and chainedBy function, but that's because this posArrMin function is reused elsewhere in my code

• Mathieu Guindon: Would be nice/beneficial to include the code for these two referenced functions, too.
• Greedo: @Mat'sMug sorry for the delay, I've put them up now, as well as a function they both reference. Obviously I could add more detail with the routine which calls applyRules, but I think that would be getting out of the scope of the question.
• Brandon Barney: To answer your question about improving the code to be more maintainable, I would recommend getting better with classes. IMO, none of this should be done with functions. It should all be class methods, functions, properties, etc. It may be a bit above your level of ability, but if you really want to improve the code (especially if you actually need this frequently) you should be using a class for the process. If done right, you could build a dynamic decision tree just by specifying how many classes to create (and parents, children, nodes, etc).
• Brandon Barney: To elaborate a little further, from what I can tell by your chart, your code boils down to Input, Test Group n, Test Conditions (n(x,y), n+1(x, y), n+2...). Then, the real method behind the madness is the TestDriver who likely needs a TestWriter, and a ResultRetriever. A structure like this should allow you to create the driver with the inputs, and let it do the work dynamically.
• Raystafarian: Do you have an example of what collection would be passed to applyRules?

Answer 1

I see how you struggle with your SELECT CASE in ApplyRules. It took some charting, but I think this is optimized

Private Function applyRules(ByVal imgGrid As Collection) As gridInstruction 
 Dim step1 As Boolean
 Dim step2 As Byte
 Dim step3 As Byte
 step1 = (imgGrid("B2").Left = 0)
 If firstcol Then
 step2 = bestChain("b2", imgGrid)
 Else
 step2 = chainedBy("b2", imgGrid)
 End If
 Select Case Str(firstcol & step2)
 Case "11"
 applyRules = Place_Chain
 Case "12", "13"
 step3 = chainedBy("C" & step2, imgGrid)
 Case "01"
 applyRules = Place_Break
 Case "02", "03"
 step3 = bestChain("A" & step2, imgGrid)
 End Select
 If Not step2 = 1 Then
 Select Case step2 & step3
 Case 22, 33
 applyRules = Place_Chain
 Case 31, 32
 applyRules = Skip
 Case 21
 If firstcol Then Skip
 Else: applyRules = Place_Break
 End If
 Case 23
 If firstcol Then
 applyRules = Place_Chain
 Else: applyRules = Place_Chain_Flag
 End If
 End Select
 End If
End Function

Obviously you'll need to qualify some of those if they are range references.

Answer 2

I don't mean to drag this up but have you considered a recursion function? Not so long ago I created a binary CART model in VBA that uses a basic recursive structure along the lines of:-

Function A - Call function B to add row to output recordset object - Check for leaf conditions; exit function early if yes - Call function C to calculate best split and GINI with current recordset - Filter current recordset by L branch condition of optimal split - Recursively call Function A, passing filtered recordset - - Filter current recordset by R branch condition - Recursively call Function A, passing filtered recordset

It's not a huge amount of code at all and the hardest part was getting used to the way VBA treats ADODB.recordset objects and filtering.

• dfhwze: Could you suggest how the recursive function could be implemented in the OP?