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