Grand Refactoring

ralmond · Jan 5, 2020 · a780f79 · a780f79
1 parent f9d9797
commit a780f79
Show file tree

Hide file tree

Showing 25 changed files with 287 additions and 770 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,10 +1,10 @@
 Package: PNetica
-Version: 0.7-1
-Date: 2019/10/21
+Version: 0.8-2
+Date: 2019/12/17
 Title: Parameterized Bayesian Networks Netica Interface
 Author: Russell Almond
 Maintainer: Russell Almond <[email protected]>
-Depends: R (>= 3.0), RNetica (>= 0.7), CPTtools (>= 0.5), Peanut (>= 0.6), futile.logger, methods
+Depends: R (>= 3.0), RNetica (>= 0.7), CPTtools (>= 0.5), Peanut (>= 0.8), futile.logger, methods
 Description: This package provides RNetica implementation of Peanut interface.
 License: Artistic-2.0 
 URL: http://pluto.coe.fsu.edu/RNetica

diff --git a/NAMESPACE b/NAMESPACE
@@ -31,13 +31,19 @@ exportMethods(PnodeName,"PnodeName<-",
               "PnodeStateValues<-",PnodeParents,
               PnodeStateBounds, "PnodeStateBounds<-",
               "PnodeParents<-", isPnodeContinuous,
-              PnodeParentNames,PnodeNumParents) #NeticaNode
+              PnodeParentNames,PnodeNumParents,
+              PnodeEvidence,"PnodeEvidence<-",
+              PnodePriorWeight, "PnodePriorWeight<-",
+              PnodePostWeight,
+              PnodeProbs, "PnodeProbs<-"
+              ) #NeticaNode
 
 exportMethods(PnetName,"PnetName<-",
               PnetTitle,"PnetTitle<-",
               PnetDescription,"PnetDescription<-",
               PnetPathname,"PnetPathname<-",
-              PnetHub,"PnetHub<-") #NeticaBN
+              PnetHub,"PnetHub<-",
+              PnetCompile) #NeticaBN
 
 exportMethods(PnetFindNode)
 export(MakePnet.NeticaBN,MakePnode.NeticaNode) ## Not actually S3 Methods

diff --git a/R/BNNetica.R b/R/BNNetica.R
@@ -174,6 +174,74 @@ setMethod("PnodeNumParents","NeticaNode", function (node)
   length(NodeParents(node)))
 
 
+setMethod("PnodeEvidence","NeticaNode",
+          function(node) {
+            if (is.continuous(node)) {
+              res <- NodeValue(node)
+            } else {
+              res <- NodeFinding(node)
+              if (res=="@NO FINDING") {
+                res <- NA
+              } else if (res=="@LIKELIHOOD") {
+                res <- NodeLikelihood(node)
+              } else if (res=="@NEGATIVE FINDINGS") {
+                res <- NodeLikelihood(node)
+              }
+            }
+            res
+          })
+
+
+setMethod("PnodeEvidence<-",c("NeticaNode","numeric"),
+          function (node,value) {
+            if (length(value) == 1L) {
+              NodeValue(node) <- value
+            } else if (length(value)==PnodeNumStates(node)) {
+              NodeLikelihood(node) <- value
+            }
+            invisible(node)
+          })
+
+setOldClass("difftime")
+setMethod("PnodeEvidence<-",c("NeticaNode","difftime"),
+          function (node,value) {
+            units(value) <- "secs"
+            NodeValue(node) <- as.numeric(value)
+          })
+setMethod("PnodeEvidence<-",c("NeticaNode","character"),
+          function (node,value) {
+            ov1 <- value
+            sts <- NodeStates(node)
+            if (!(ov1 %in% sts)) {
+              ov1 <- sts[toupper(sts)==toupper(ov1)]
+            }
+            if (length(ov1) > 0L) {
+              flog.trace("Setting observable %s to %s.",NodeName(node),ov1)
+              NodeFinding(node) <- ov1
+            } else {
+              flog.warn("Observable %s has unknown value %s, skipping.",
+                        NodeName(node), ov1)
+            }
+            invisible(node)
+          })
+setMethod("PnodeEvidence<-",c("NeticaNode","factor"),
+          function (node,value) {
+            PnodeEvidence(node) <- as.character(value)
+            })
+setMethod("PnodeEvidence<-",c("NeticaNode","NULL"),
+          function (node,value) {
+            RetractNodeFinding(node)
+            })
+
+setMethod("PnodeEvidence<-",c("NeticaNode","ANY"),
+          function(node,value) {
+            warning("Don't know how to set ",NodeName(node)," to ",
+                 as.character(value),".  Skipping.")
+          })
+
+
+
+##############################################################
 #### Net Functions
 
 setMethod("PnetName","NeticaBN", function (net){
@@ -265,3 +333,4 @@ setMethod("unserializePnet","NeticaSession",
             ReadNetworks(tmpfile,factory)
           })
 
+setMethod("PnetCompile","NeticaBN",function(net) CompileNetwork(net))
diff --git a/R/PnetNetica.R b/R/PnetNetica.R
@@ -8,7 +8,10 @@
 ## A field called "priorWeight" which gives the default prior weight
 ## to use.
 
-
+## This is a total hack, but R won't let me modify Peanut after it is
+## locked and loaded.
+setClassUnion("net.bridge","NeticaBN")
+setIs("net.bridge","Pnet")
 setMethod("as.Pnet","NeticaBN",function(x) x)
 setMethod("is.Pnet","NeticaBN",function(x) TRUE)
 
@@ -101,7 +104,7 @@ setMethod("PnetAdjoin","NeticaBN", function (hub, spoke) {
 
 setMethod("PnetDetach","NeticaBN", function (motif, spoke) {
   # Bug in RN_AbsorbNodes
-  # AbsorbNodes(NetworkNodesInSet(motif,paste("Spoke",NetworkName(spoke),sep="_")))
+  AbsorbNodes(NetworkNodesInSet(motif,paste("Spoke",NetworkName(spoke),sep="_")))
 })
 
 
@@ -117,6 +120,8 @@ setMethod("PnetDetach","NeticaBN", function (motif, spoke) {
 ## priorWeight -- a numeric value or a vector of numeric values for
 ## each row of the CPT.   Inherits from the net if not available.
 
+setClassUnion("node.bridge","NeticaNode")
+setIs("node.bridge","Pnode")
 
 setMethod("as.Pnode","NeticaNode",function(x) {
   NodeSets(x) <- union("pnodes",NodeSets(x))
@@ -202,6 +207,20 @@ setMethod("PnodePriorWeight<-","NeticaNode", function (node,value) {
   node
 })
 
+setMethod("PnodePostWeight","NeticaNode", function (node) {
+  NodeExperience(node)
+})
+
+setMethod("PnodeProbs","NeticaNode", function (node) {
+  NodeProbs(node)
+})
+
+setMethod("PnodeProbs<-","NeticaNode", function (node,value) {
+  NodeProbs(node) <- value
+  node
+})
+
+
 setMethod("PnodeParentTvals","NeticaNode", function (node) {
   lapply(NodeParents(node),PnodeStateValues)
 })

diff --git a/R/Warehouse.R b/R/Warehouse.R
@@ -4,6 +4,7 @@ BNWarehouse <- setClass("BNWarehouse",
                                address="character",
                                key="character")
                        )
+setIs("BNWarehouse","PnetWarehouse")
 setMethod(ClearWarehouse,"BNWarehouse",
           function(warehouse) {
             warning("To clear warehouse, stop and restart session.")
@@ -122,6 +123,7 @@ NNWarehouse <- setClass("NNWarehouse",
                                key="character")
                        )
 
+setIs("NNWarehouse","PnodeWarehouse")
 
 setMethod(ClearWarehouse,"NNWarehouse",
           function(warehouse) {

diff --git a/TODO b/TODO
@@ -0,0 +1,175 @@
+prepare_Rd: BuildTable.Rd:67-68: Dropping empty section \examples
+prepare_Rd: MakePnet.NeticaBN.Rd:26-28: Dropping empty section \details
+prepare_Rd: MakePnet.NeticaBN.Rd:29-35: Dropping empty section \value
+prepare_Rd: MakePnet.NeticaBN.Rd:42-44: Dropping empty section \note
+prepare_Rd: MakePnet.NeticaBN.Rd:39-41: Dropping empty section \author
+prepare_Rd: MakePnet.NeticaBN.Rd:36-38: Dropping empty section \references
+prepare_Rd: MakePnet.NeticaBN.Rd:48-50: Dropping empty section \seealso
+prepare_Rd: MakePnet.NeticaBN.Rd:51-52: Dropping empty section \examples
+prepare_Rd: MakePnode.NeticaNode.Rd:24-26: Dropping empty section \details
+prepare_Rd: MakePnode.NeticaNode.Rd:27-33: Dropping empty section \value
+prepare_Rd: MakePnode.NeticaNode.Rd:40-42: Dropping empty section \note
+prepare_Rd: MakePnode.NeticaNode.Rd:37-39: Dropping empty section \author
+prepare_Rd: MakePnode.NeticaNode.Rd:34-36: Dropping empty section \references
+prepare_Rd: MakePnode.NeticaNode.Rd:46-48: Dropping empty section \seealso
+prepare_Rd: MakePnode.NeticaNode.Rd:49-50: Dropping empty section \examples
+prepare_Rd: maxCPTParam.Rd:83-85: Dropping empty section \examples
+Missing link or links in documentation object 'BuildTable.Rd':
+  ‘Pnode.NeticaNode’ ‘[RNetica]{[.NeticaNode}’
+
+Missing link or links in documentation object 'PNetica-package.Rd':
+  ‘Pnet.NeticaBN’ ‘Pnode.NeticaNode’ ‘PnetPnodes.NeticaBN’
+  ‘PnetPriorWeight.NeticaBN’ ‘[Peanut]{Pnet.default}’
+
+Missing link or links in documentation object 'PnetFindNode.Rd':
+  ‘PnetNode’
+
+Missing link or links in documentation object 'PnetSerialize.Rd':
+  ‘[base]{serialize(...,NULL)}’
+
+Missing link or links in documentation object 'PnodeParentTvals.Rd':
+  ‘Pnode.NeticaNode’
+
+Missing link or links in documentation object 'calcExpTables.Rd':
+  ‘Pnode.NeticaNode’ ‘Pnet.NeticaBN’
+
+Missing link or links in documentation object 'calcPnetLLike.Rd':
+  ‘Pnet.NeticaBN’
+
+Missing link or links in documentation object 'maxCPTParam.Rd':
+  ‘Pnode.NeticaNode’
+
+See section 'Cross-references' in the 'Writing R Extensions' manual.
+
+* checking for missing documentation entries ... WARNING
+
+   Undocumented code objects:
+  ‘BNWarehouse’ ‘NNWarehouse’ ‘WarehouseDirectory’
+  ‘WarehouseDirectory<-’
+Undocumented S4 classes:
+  ‘BNWarehouse’ ‘NNWarehouse’
+Undocumented S4 methods:
+  generic 'BuildTable' and siglist 'NeticaNode'
+  generic 'ClearWarehouse' and siglist 'BNWarehouse'
+  generic 'ClearWarehouse' and siglist 'NNWarehouse'
+  generic 'PnetCompile' and siglist 'NeticaBN'
+  generic 'PnetDescription' and siglist 'NeticaBN'
+  generic 'PnetDescription<-' and siglist 'NeticaBN'
+  generic 'PnetFindNode' and siglist 'NeticaBN'
+  generic 'PnetHub' and siglist 'NeticaBN'
+  generic 'PnetHub<-' and siglist 'NeticaBN'
+  generic 'PnetName' and siglist 'NeticaBN'
+  generic 'PnetName<-' and siglist 'NeticaBN'
+  generic 'PnetPathname' and siglist 'NeticaBN'
+  generic 'PnetPathname<-' and siglist 'NeticaBN'
+  generic 'PnetPnodes' and siglist 'NeticaBN'
+  generic 'PnetPnodes<-' and siglist 'NeticaBN'
+  generic 'PnetPriorWeight' and siglist 'NeticaBN'
+  generic 'PnetPriorWeight<-' and siglist 'NeticaBN'
+  generic 'PnetTitle' and siglist 'NeticaBN'
+  generic 'PnetTitle<-' and siglist 'NeticaBN'
+  generic 'Pnode' and siglist 'NeticaNode'
+  generic 'PnodeBetas' and siglist 'NeticaNode'
+  generic 'PnodeBetas<-' and siglist 'NeticaNode'
+  generic 'PnodeDescription' and siglist 'NeticaNode'
+  generic 'PnodeDescription<-' and siglist 'NeticaNode'
+  generic 'PnodeEAP' and siglist 'NeticaBN,NeticaNode'
+  generic 'PnodeEvidence' and siglist 'NeticaNode'
+  generic 'PnodeEvidence<-' and siglist 'NeticaNode,ANY'
+  generic 'PnodeEvidence<-' and siglist 'NeticaNode,NULL'
+  generic 'PnodeEvidence<-' and siglist 'NeticaNode,character'
+  generic 'PnodeEvidence<-' and siglist 'NeticaNode,difftime'
+  generic 'PnodeEvidence<-' and siglist 'NeticaNode,factor'
+  generic 'PnodeEvidence<-' and siglist 'NeticaNode,numeric'
+  generic 'PnodeLabels' and siglist 'NeticaNode'
+  generic 'PnodeLabels<-' and siglist 'NeticaNode'
+  generic 'PnodeLink' and siglist 'NeticaNode'
+  generic 'PnodeLink<-' and siglist 'NeticaNode'
+  generic 'PnodeLinkScale' and siglist 'NeticaNode'
+  generic 'PnodeLinkScale<-' and siglist 'NeticaNode'
+  generic 'PnodeLnAlphas' and siglist 'NeticaNode'
+  generic 'PnodeLnAlphas<-' and siglist 'NeticaNode'
+  generic 'PnodeMargin' and siglist 'NeticaBN,NeticaNode'
+  generic 'PnodeMedian' and siglist 'NeticaBN,NeticaNode'
+  generic 'PnodeMode' and siglist 'NeticaBN,NeticaNode'
+  generic 'PnodeName' and siglist 'NeticaNode'
+  generic 'PnodeName<-' and siglist 'NeticaNode'
+  generic 'PnodeNet' and siglist 'NeticaNode'
+  generic 'PnodeNumParents' and siglist 'NeticaNode'
+  generic 'PnodeNumStates' and siglist 'NeticaNode'
+  generic 'PnodeParentNames' and siglist 'NeticaNode'
+  generic 'PnodeParentTvals' and siglist 'NeticaNode'
+  generic 'PnodeParents' and siglist 'NeticaNode'
+  generic 'PnodeParents<-' and siglist 'NeticaNode'
+  generic 'PnodePostWeight' and siglist 'NeticaNode'
+  generic 'PnodePriorWeight' and siglist 'NeticaNode'
+  generic 'PnodePriorWeight<-' and siglist 'NeticaNode'
+  generic 'PnodeProbs' and siglist 'NeticaNode'
+  generic 'PnodeProbs<-' and siglist 'NeticaNode'
+  generic 'PnodeQ' and siglist 'NeticaNode'
+  generic 'PnodeQ<-' and siglist 'NeticaNode'
+  generic 'PnodeRules' and siglist 'NeticaNode'
+  generic 'PnodeRules<-' and siglist 'NeticaNode'
+  generic 'PnodeSD' and siglist 'NeticaBN,NeticaNode'
+  generic 'PnodeStateBounds' and siglist 'NeticaNode'
+  generic 'PnodeStateBounds<-' and siglist 'NeticaNode'
+  generic 'PnodeStateDescriptions' and siglist 'NeticaNode'
+  generic 'PnodeStateDescriptions<-' and siglist 'NeticaNode'
+  generic 'PnodeStateTitles' and siglist 'NeticaNode'
+  generic 'PnodeStateTitles<-' and siglist 'NeticaNode'
+  generic 'PnodeStateValues' and siglist 'NeticaNode'
+  generic 'PnodeStateValues<-' and siglist 'NeticaNode'
+  generic 'PnodeStates' and siglist 'NeticaNode'
+  generic 'PnodeStates<-' and siglist 'NeticaNode'
+  generic 'PnodeTitle' and siglist 'NeticaNode'
+  generic 'PnodeTitle<-' and siglist 'NeticaNode'
+  generic 'WarehouseData' and siglist 'BNWarehouse'
+  generic 'WarehouseData' and siglist 'NNWarehouse'
+  generic 'WarehouseDirectory' and siglist 'BNWarehouse'
+  generic 'WarehouseDirectory<-' and siglist 'BNWarehouse'
+  generic 'WarehouseFetch' and siglist 'BNWarehouse'
+  generic 'WarehouseFetch' and siglist 'NNWarehouse'
+  generic 'WarehouseFree' and siglist 'BNWarehouse'
+  generic 'WarehouseFree' and siglist 'NNWarehouse'
+  generic 'WarehouseInventory' and siglist 'BNWarehouse'
+  generic 'WarehouseInventory' and siglist 'NNWarehouse'
+  generic 'WarehouseMake' and siglist 'BNWarehouse'
+  generic 'WarehouseMake' and siglist 'NNWarehouse'
+  generic 'WarehouseManifest' and siglist 'BNWarehouse'
+  generic 'WarehouseManifest' and siglist 'NNWarehouse'
+  generic 'WarehouseManifest<-' and siglist 'BNWarehouse,data.frame'
+  generic 'WarehouseManifest<-' and siglist 'NNWarehouse,data.frame'
+  generic 'WarehouseSupply' and siglist 'ANY'
+  generic 'WarehouseUnpack' and siglist 'BNWarehouse'
+  generic 'as.Pnet' and siglist 'NeticaBN'
+  generic 'as.Pnode' and siglist 'NeticaNode'
+  generic 'calcExpTables' and siglist 'NeticaBN'
+  generic 'calcPnetLLike' and siglist 'NeticaBN'
+  generic 'is.Pnet' and siglist 'NeticaBN'
+  generic 'is.PnetWarehouse' and siglist 'BNWarehouse'
+  generic 'is.Pnode' and siglist 'NeticaNode'
+  generic 'is.PnodeWarehouse' and siglist 'NNWarehouse'
+  generic 'isPnodeContinuous' and siglist 'NeticaNode'
+  generic 'maxCPTParam' and siglist 'NeticaNode'
+* checking for code/documentation mismatches ... WARNING
+Functions or methods with usage in documentation object 'BuildTable.NeticaNode' but not in code:
+  BuildTable.NeticaNode
+
+Functions or methods with usage in documentation object 'PnetFindNode' but not in code:
+  PnetAllNodes
+
+Functions or methods with usage in documentation object 'PnodeParentTvals.NeticaNode' but not in code:
+  PnodeParentTvals.NeticaNode
+
+Functions or methods with usage in documentation object 'calcExpTables.NeticaBN' but not in code:
+  calcExpTables.NeticaBN
+
+Functions or methods with usage in documentation object 'calcPnetLLike.NeticaBN' but not in code:
+  calcPnetLLike.NeticaBN
+
+Functions or methods with usage in documentation object 'maxCPTParam.NeticaNode' but not in code:
+  maxCPTParam.NeticaNode
+
+
+
+
diff --git a/inst/testnets/IRT10.2PL.true.dne b/inst/testnets/IRT10.2PL.true.dne
@@ -2,7 +2,7 @@
 
 // File created by an unlicensed user using Netica 5.04 on 06/25/2015 at 01:46:44 PM.
 
-bnet IRT10_2PL {
+bnet IRT10_2PL_true {
 autoupdate = FALSE;
 whenchanged = 1435254363;
 user U1 {