Sequential Learning

Dim vbafactory As New HVBA
Public cellX As Integer
Public cellY As Integer

'This example presents a skeleton for sequential learning.
'Sequential learning, or adaptation, is an update process applied
'to the conditional probability tables.  After a network has been
'built, sequential learning can be applied during operation in
'order to maintain the correspondence between the model
'(conditional probability tables) and the real-world domain.

'After the network is loaded in HUGIN, the learning parameters
'are specified.  Then follows the build-up and entering of cases,
'and finally, the tables are updated and node marginals are printed.

Public Sub Adapt(fileName As String)

    Dim netFileName As String
    netFileName = fileName & ".net"
    Dim Dom As Domain
    Set Dom = vbafactory.ParseDomain(netFileName, New DefaultClassParseListener)
    Dim logFileName As String
    logFileName = fileName & ".log"
    Dom.OpenLogFile (logFileName)
    Dom.Compile

    Call SpecifyLearningParameters(Dom)
    Call PrintLearningParameters(Dom)
    Call EnterCase(Dom)
    Call PrintCase(Dom)
    Call Dom.Propagate(Equilibrium_H_EQUILIBRIUM_SUM, EvidenceMode_H_EVIDENCE_MODE_NORMAL)

    Dom.Adapt
    Dom.Initialize

    Call PrintNodeMarginals(Dom)

    Dom.SaveAsNet ("q.net")

End Sub

'Creates an experience and fading table for each node
'in the domain.
Private Sub SpecifyLearningParameters(Dom As Domain)

    Dim nl As NodeList
    Set nl = Dom.GetNodes

    For Each node In nl
        Dim table As table
        Set table = node.GetExperienceTable
        For i = 0 To table.GetSize - 1
            Call table.SetDataItem(i, 1)
        Next

        Set table = node.GetFadingTable
        For i = 0 To table.GetSize - 1
            Call table.SetDataItem(i, 1)
        Next
    Next

End Sub

' Write the program output to a Worksheet named "Output"
Public Sub WriteToWorksheet(text As String)
    Dim output As Worksheet
    On Error Resume Next
    Set output = Sheets("Output")
    On Error GoTo 0
    Set output = Sheets("Output")
    output.Cells(cellY, cellX) = text
End Sub

'Writes the values of the experience and fading tables
'for each node in the domain to the "Output" worksheet.
Private Sub PrintLearningParameters(Dom As Domain)

    Dim nl As NodeList
    Set nl = Dom.GetNodes

    For Each node In nl
        WriteToWorksheet (node.GetLabel & " (" & node.GetName & "): ")
        cellY = cellY + 1
        cellX = 1
        Dim table As table
        Dim data As Variant
        Dim tblsize As LongPtr

        If node.HasExperienceTable Then
            Set table = node.GetExperienceTable
            data = table.GetData
            tblsize = table.GetSize

            For i = 0 To tblsize - 1
                WriteToWorksheet (data(i))
                cellX = cellX + 1
            Next
            cellY = cellY + 1
            cellX = 1
        Else
            WriteToWorksheet ("No experience table")
        End If
        If node.HasFadingTable Then
            Set table = node.GetFadingTable
            data = table.GetData
            tblsize = table.GetSize

            For i = 0 To tblsize - 1
                WriteToWorksheet (data(i))
                cellX = cellX + 1
            Next
            cellY = cellY + 1
            cellX = 1
        Else
            WriteToWorksheet ("No fading table")
        End If
    Next
    cellY = cellY + 1
End Sub

'Selects a state for each node in the domain.
Private Sub EnterCase(Dom As Domain)

    Dim nl As NodeList
    Set nl = Dom.GetNodes

    For Each dcNode In nl
        dcNode.SelectState (0)
    Next
    Dim node As DiscreteChanceNode
    Set node = nl(1)
    node.RetractFindings

End Sub

'Prints the nodes name and whether or not evidence has
'been entered for that node for each node in the domain.
Private Sub PrintCase(Dom As Domain)

    Dim nl As NodeList
    Set nl = Dom.GetNodes

    For Each node In nl
        If node.EvidenceIsEntered Then
            WriteToWorksheet (" (" & node.GetName & ", evidence is entered) ")
        Else
            WriteToWorksheet (" (" & node.GetName & ", evidence is not entered) ")
        End If
    cellY = cellY + 1
    Next
    cellY = cellY + 1

End Sub

'For each node in the domain first the label and name are
'printed, and then the state label and belief of this state
'are printed for each state in the node.
Private Sub PrintNodeMarginals(Dom As Domain)

    Dim nl As NodeList
    Set nl = Dom.GetNodes

    For Each node In nl
        Dim nStates As Integer
        nStates = node.GetNumberOfStates

        WriteToWorksheet (node.GetLabel & " (" & node.GetName & ")")
        cellY = cellY + 1
        cellX = 1
        For i = 0 To nStates - 1
            WriteToWorksheet (" - " & node.GetStateLabel(i) & ": " & node.GetBelief(i))
            cellY = cellY + 1
        Next
        cellY = cellY + 1
    Next

End Sub

'Dialogue to promt the user to select a file
Public Function SelectFile() As String
    Dim intChoice As Integer
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    fd.AllowMultiSelect = False
    intChoice = fd.Show
    If intChoice <> 0 Then
        SelectFile = fd.SelectedItems(1)
    End If
End Function

Public Sub Main()

    cellX = 1
    cellY = 1
    Dim output As Worksheet
    On Error Resume Next
    Set output = Sheets("Output")
    On Error GoTo ErrorHandler
    If output Is Nothing Then
        Sheets.Add().Name = "Output"
    Else
        Sheets("Output").Cells.Clear
    End If
    Dim netFile As String
    Dim fileName As String
    netFile = SelectFile
    fileName = Left(netFile, (Len(netFile) - 4))
    Call Adapt(fileName)

Exit Sub
ErrorHandler:
    Call MsgBox("An Error Occurred in your Script" & vbNewLine & TypeName(vbafactory.lastExceptionHugin) & vbNewLine & vbafactory.lastExceptionHugin.Message, vbCritical, "Error")

End Sub
Close