'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