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:

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

Would be nice/beneficial to include the code for these two referenced functions, too. — Mathieu Guindon
– Mathieu Guindon, Commented Aug 17, 2017 at 11:14
@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. — Greedo
– Greedo, Commented Aug 17, 2017 at 12:22
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
– Brandon Barney, Commented Aug 22, 2017 at 14:49
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. — Brandon Barney
– Brandon Barney, Commented Aug 22, 2017 at 14:54
Do you have an example of what collection would be passed to applyRules? — Raystafarian
– Raystafarian, Commented Mar 4, 2018 at 5:52

Raystafarian · Accepted Answer · 2018-03-15 23:36:19Z

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.

Jon · Accepted Answer · 2019-10-08 11:15:39Z

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.

Could you suggest how the recursive function could be implemented in the OP? — dfhwze
– dfhwze, Commented Oct 8, 2019 at 12:11

Stack Exchange Network

Coding Decision Trees in VBA

Additional functions

2 Answers 2

You must log in to answer this question.

Hot Network Questions

Coding Decision Trees in VBA

Additional functions

2 Answers 2

You must log in to answer this question.

Related

Hot Network Questions