Load and Propagate

'This function parses the given NET file, compiles the network,
'and prints the prior beliefs and expected utilities of all
'nodes.  If a case file is given, the function loads the file,
'propagates the evidence, and prints the updated results.
'
'If the network is a LIMID, we assume that we should compute
'policies for all decisions (rather than use the ones specified
'in the NET file).  Likewise, we update the policies when new
'evidence arrives.
Private Sub LAP(fileName As String, caseFile As String)
    Dim vbafactory As New HVBA
    On Error GoTo ErrorHandler
    Dim plstn As New DefaultClassParseListener
    Dim Dom As Domain
    Set Dom = vbafactory.ParseDomain(fileName & ".net", plstn)
    Dom.OpenLogFile (fileName & ".log")
    Dom.Triangulate (TriangulationMethod_H_TM_BEST_GREEDY)
    Dom.Compile
    Dom.CloseLogFile
    Dim hasUtilities As Boolean
    hasUtilities = ContainsUtilities(Dom.GetNodes)
    If Not hasUtilities Then
        WriteToWorksheet ("Prior Beliefs: ")
    Else
        Dom.UpdatePolicies
        WriteToWorksheet ("Overall expected utility: " & Dom.GetExpectedUtility)
        WriteToWorksheet ("Prior beliefs (and expected utilities): ")
    End If


    Call PrintBeliefsAndUtilities(Dom)
    If caseFile <> vbNullString Then
        Call Dom.ParseCase(caseFile, plstn)
        WriteToWorksheet ("")
        WriteToWorksheet ("")
        WriteToWorksheet ("Propagating the evidence specified in " & caseFile)

        Call Dom.Propagate(Equilibrium_H_EQUILIBRIUM_SUM, EvidenceMode_H_EVIDENCE_MODE_NORMAL)
        WriteToWorksheet ("")
        WriteToWorksheet ("P(evidence) = " & Dom.GetNormalizationConstant)
        WriteToWorksheet ("")
        If Not hasUtilities Then
            WriteToWorksheet ("Updated Beliefs: ")
        Else
            Dom.UpdatePolicies
            WriteToWorksheet ("Overall expected utility: " & Dom.GetExpectedUtility)
            WriteToWorksheet ("Prior beliefs (and expected utilities): ")
        End If
        Call PrintBeliefsAndUtilities(Dom)
    End If
    Dom.Delete
Exit Sub
ErrorHandler:
    Call MsgBox("An Error Occurred in your Script" & vbNewLine & TypeName(vbafactory.lastExceptionHugin) & vbNewLine & vbafactory.lastExceptionHugin.Message, vbCritical, "Error")
End Sub

'Prints beliefs and utilities of all nodes in the domain.
'The generic node type exists, but does not contain
'the methods to get values out of nodes, they have to
'be cast to their specific types before printing.
Private Sub PrintBeliefsAndUtilities(Dom As Domain)
    Dim nodes As NodeList
    Dim hasUtilities As Boolean
    Set nodes = Dom.GetNodes
    hasUtilities = ContainsUtilities(nodes)
    Dim vbafactory As New HVBA
    For Each node In nodes
        WriteToWorksheet ("")
        WriteToWorksheet (node.GetLabel & " ( " & node.GetName & " ) ")

        If TypeOf node Is UtilityNode Then
            Dim un As UtilityNode
            Set un = node
            WriteToWorksheet ("  - " & un.GetExpectedUtility)

        ElseIf TypeOf node Is DiscreteNode Then
            Dim dNode As DiscreteNode
            Set dNode = node
            Dim stateIdx As LongPtr
            For stateIdx = 0 To dNode.GetNumberOfStates - 1
                WriteToWorksheet (("  - " & dNode.GetStateLabel(stateIdx) & " " & dNode.GetBelief(stateIdx)))
                If (hasUtilities) Then
                    WriteToWorksheet ("  ( " & dNode.GetExpectedUtility(stateIdx) & " ) ")
                Else
                    WriteToWorksheet ("")
                End If
            Next
        ElseIf TypeOf node Is FunctionNode Then
            On Error GoTo ErrorHandler
            Dim fNode As FunctionNode
            Set fNode = node
            Dim value As Double
            value = fNode.GetValue
            WriteToWorksheet ("  - Function value: " & value)
        Else
            Dim ccNode As ContinuousChanceNode
            Set ccNode = node
            WriteToWorksheet ("  - Mean : " & ccNode.GetMean)
            WriteToWorksheet ("  - SD   : " & ccNode.GetVariance)

        End If

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

'Used to figure out if the list contains at least one UtilityNode.
'It returns true if this is the case.
Private Function ContainsUtilities(list As NodeList) As Boolean
    ContainsUtilities = False

    For Each node In list
        If TypeOf node Is UtilityNode Then
            ContainsUtilities = True
            Exit For
        End If
    Next node
End Function

'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

'Writes information to a worksheet named "Output".
'Note that this method is solely used to give the
'user insight in what is happening.
'It does not make use of the hugin engine and is
'not strictly needed niether for loading nor
'propagating to work.
Public Sub WriteToWorksheet(text As String)
    Dim OutPut As Worksheet
    On Error Resume Next
    Set OutPut = Sheets("Output")
    On Error GoTo 0
    If OutPut Is Nothing Then
        Sheets.Add().Name = "Output"
    End If
    Set OutPut = Sheets("Output")
    Dim v
    Dim n As Long
    v = OutPut.Range("a1")
    If IsEmpty(v) Then
       OutPut.Cells(1, 1) = 2
       v = 2
    End If
    n = v
    OutPut.Cells(v, 1) = text
    OutPut.Cells(1, 1) = v + 1
End Sub

'Start the Example by invoking this Sub
Public Sub Main()
    Dim fileName As String
    Dim caseFile As String
    fileName = SelectFile
    fileName = Left(fileName, Len(fileName) - 4)
    Dim CaseFileSelection As Integer
    CaseFileSelection = MsgBox("Do you wish to specify a case file?", vbYesNoCancel, "Make a Choice")
    If CaseFileSelection = 6 Then
        caseFile = SelectFile
    End If
    If CaseFileSelection <> 0 Then
        Call LAP(fileName, caseFile)
    End If
End Sub
Close