Merge pull request #1 from ralmond/working

Working

.gitignore

@@ -0,0 +1 @@
+*~

ChangeLog

@@ -1,3 +1,23 @@
+2020-04-01  Russell Almond  <ralmond@Cherry>
+
+	* R/BNNetica.R: Added warning when replacing network.
+
+2020-03-14  Russell Almond  <ralmond@Cherry>
+
+	* R/Warehouse.R (WarehouseFree(BNWarehouse)): Added list argument
+	to rm.
+
+2020-03-08  Russell Almond  <ralmond@Cherry>
+
+	* R/Warehouse.R
+	(WarehouseCopy,is.legal.name,as.legal.name,is.valid): Added.
+
+2020-02-12  Rusell Almond  <ralmond@Cherry>
+
+	* R/Warehouse.R: WarehouseFree now actually deletes the network.
+	ClearWarehouse also deletes all the nets.
+
+
 2019-07-29  Rusell Almond  <ralmond@Cherry>
 
 	* R/Warehouse.R (WarehouseManifest<-): Added trimws to key columsn.

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: PNetica
-Version: 0.8-2
-Date: 2019/12/17
+Version: 0.8-3
+Date: 2020/03/12
 Title: Parameterized Bayesian Networks Netica Interface
 Author: Russell Almond
 Maintainer: Russell Almond <[email protected]>

NAMESPACE

@@ -56,7 +56,8 @@ exportMethods(ClearWarehouse,
        WarehouseMake,WarehouseFree, WarehouseUnpack,
        WarehouseInventory,
        is.PnodeWarehouse,is.PnetWarehouse,
-       WarehouseDirectory,"WarehouseDirectory<-")
+       WarehouseDirectory,"WarehouseDirectory<-",
+       WarehouseCopy,is.legal.name,as.legal.name,is.valid)
 ##export(Free,Save,Reload,Delete)     #Warehouse protocol
 ##exportMethods(Free,Save,Reload,Delete)     #Warehouse protocol
 

R/BNNetica.R

@@ -328,6 +328,8 @@ setMethod("unserializePnet","NeticaSession",
             writeLines(unserialize(data$data),tmpfile)
             oldnet <- factory$findNet(name)
             if (!is.null(oldnet) && is.active(oldnet)) {
+              flog.warn("Replacing old version of network %s.",
+                           name)
               DeleteNetwork(oldnet)
             }
             ReadNetworks(tmpfile,factory)

R/PnetNetica.R

@@ -103,8 +103,16 @@ setMethod("PnetAdjoin","NeticaBN", function (hub, spoke) {
 })
 
 setMethod("PnetDetach","NeticaBN", function (motif, spoke) {
-  # Bug in RN_AbsorbNodes
-  AbsorbNodes(NetworkNodesInSet(motif,paste("Spoke",NetworkName(spoke),sep="_")))
+    ## Bug in RN_AbsorbNodes
+    spokename <- paste("Spoke",NetworkName(spoke),sep="_")
+    tryCatch(
+        AbsorbNodes(NetworkNodesInSet(motif,spokename)),
+        error = function (e) {
+            flog.error("While absorbing nodes from %s in %s, got error %s",
+                       spokename,NetworkName(motif),conditionMessage(e))
+            flog.info("This could be a known Netica bug in version 5.04")
+        })
+    motif
 })
 
 

R/Warehouse.R

@@ -2,13 +2,28 @@ BNWarehouse <- setClass("BNWarehouse",
                        slots=c(manifest="data.frame",
                                session="NeticaSession",
                                address="character",
-                               key="character")
+                               key="character",
+                               prefix="character")
                        )
+BNWarehouse <- function(manifest=data.frame(),session=getDefaultSession(),
+                        address=".",key=c("Name"),prefix="S")
+  new("BNWarehouse",manifest=manifest, session=session, address=address,
+      key=key, prefix=prefix)
+
 setIs("BNWarehouse","PnetWarehouse")
+
 setMethod(ClearWarehouse,"BNWarehouse",
           function(warehouse) {
-            warning("To clear warehouse, stop and restart session.")
+            objs <- objects(warehouse@session$nets)
+            for (obj in objs) {
+              net <- warehouse@session$nets[[obj]]
+              if (is.NeticaBN(net) && is.active(net)) {
+                flog.trace("Clearing Network %s",obj)
+                DeleteNetwork(net)
+              }
+            }
           })
+
 setMethod(WarehouseManifest,"BNWarehouse",
           function(warehouse) {warehouse@manifest})
 setMethod("WarehouseManifest<-",c("BNWarehouse","data.frame"),
@@ -92,9 +107,39 @@ setMethod(WarehouseMake,"BNWarehouse",
 
 setMethod(WarehouseFree,"BNWarehouse",
           function(warehouse,name) {
-            warning("To free network, call DeleteNetworks.")
+            net <- WarehouseFetch(warehouse,name)
+            if (is.null(net)) {
+              flog.trace("Network for name %s not found, skipping.",name)
+            } else {
+              if (is.active(net))
+                DeleteNetwork(net)
+              if (!is.null(warehouse@session$nets[[name]]))
+                rm(list=name,envir=warehouse@session$nets)
+            }
+          })
+
+setMethod(WarehouseCopy,c("BNWarehouse","NeticaBN"),
+          function(warehouse,obj,newname) {
+            newname <- as.legal.name(warehouse,newname)
+            CopyNetworks(obj,newname)
           })
 
+setMethod(is.legal.name,"BNWarehouse",
+          function(warehouse,name)
+            is.IDname(name)
+          )
+
+setMethod(as.legal.name,"BNWarehouse",
+          function(warehouse,name)
+            as.IDname(name,warehouse@prefix)
+          )
+
+setMethod(is.valid,"BNWarehouse",
+          function(warehouse,object)
+            is.active(object)
+          )
+
+
 setMethod(WarehouseInventory,"BNWarehouse",
           function(warehouse) {
             allKeys <- warehouse@manifest[,warehouse@key,drop=FALSE]
@@ -120,8 +165,13 @@ setMethod("WarehouseUnpack", "BNWarehouse",
 NNWarehouse <- setClass("NNWarehouse",
                        slots=c(manifest="data.frame",
                                session="NeticaSession",
-                               key="character")
+                               key="character",
+                               prefix="character")
                        )
+NNWarehouse <- function(manifest=data.frame(),session=getDefaultSession(),
+                        key=c("Model","NodeName"),prefix="V")
+  new("NNWarehouse",manifest=manifest, session=session,
+      key=key, prefix=prefix)
 
 setIs("NNWarehouse","PnodeWarehouse")
 
@@ -181,9 +231,41 @@ setMethod(WarehouseMake,"NNWarehouse",
 
 setMethod(WarehouseFree,"NNWarehouse",
           function(warehouse,name) {
-            warning("Delete the node to free it.")
+            node <- WarehouseFetch(warehouse,name)
+            if (is.null(node)) {
+              flog.trace("Node for name %s not found, skipping.",name)
+            } else {
+              if (is.active(node))
+                DeleteNodes(node)
+            }
           })
 
+setMethod(WarehouseCopy,c("NNWarehouse","NeticaNode"),
+          function(warehouse,obj,newname) {
+            newname <- as.legal.name(warehouse,newname)
+            if (length(newname) != 2L)
+              stop("Expected key to look like (net, node).")
+            newnet <- warehouse@session$nets[[newname[1]]]
+            if (is.null(newnet))
+              stop("Network ",newname[1]," does not exist.")
+            CopyNodes(obj,newname[2],newnet=newnet)
+          })
+
+setMethod(is.legal.name,"NNWarehouse",
+          function(warehouse,name)
+            is.IDname(name)
+          )
+
+setMethod(as.legal.name,"NNWarehouse",
+          function(warehouse,name)
+            as.IDname(name,warehouse@prefix)
+          )
+
+setMethod(is.valid,"NNWarehouse",
+          function(warehouse,object)
+            is.active(object)
+          )
+
 setMethod(is.PnodeWarehouse,"NNWarehouse",
           function(obj) {TRUE})
 

TODO

@@ -1,3 +1,11 @@
+* Looks like we can't directly make NeticaBN a subclass of PNet.  We
+   need to create a wrapper class, which will mean rewriting most of
+   PNetica.  [Fixed this by just using "ANY" instead of "PNet" or
+   "Pnode" classes.]
+* Create a mode for warehouses where they generate an error rather
+   than autogenerate a blank network.
+
+
 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
@@ -14,19 +22,11 @@ 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’
 
@@ -44,13 +44,12 @@ See section 'Cross-references' in the 'Writing R Extensions' manual.
 * checking for missing documentation entries ... WARNING
 
    Undocumented code objects:
-  ‘BNWarehouse’ ‘NNWarehouse’ ‘WarehouseDirectory’
+  ‘WarehouseDirectory’
   ‘WarehouseDirectory<-’
 Undocumented S4 classes:
-  ‘BNWarehouse’ ‘NNWarehouse’
+  ‘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'

inst/testnets/PPcompEM.dne

@@ -1,33 +1,60 @@
 // ~->[DNET-1]->~
 
-// File created by an unlicensed user using Netica 5.04 on 04/09/2018 at 07:32:19 PM.
+// File created by AlmondR at FloridaStateU using Netica 5.24 on Apr 09, 2020 at 20:39:21 UTC.
 
 bnet PPcompEM {
 autoupdate = FALSE;
 title = "Compensatory Evidence Model";
 comment = "An evidence model with a single compensatory observable";
 whenchanged = 1523316631;
+
+visual V1 {
+	defdispform = BELIEFBARS;
+	nodelabeling = TITLE;
+	NodeMaxNumEntries = 50;
+	nodefont = font {shape= "Arial"; size= 9;};
+	linkfont = font {shape= "Arial"; size= 9;};
+	windowposn = (26, 26, 1002, 353);
+	resolution = 72;
+	drawingbounds = (1080, 720);
+	showpagebreaks = FALSE;
+	usegrid = TRUE;
+	gridspace = (6, 6);
+	NodeSet Node {BuiltIn = 1; Color = 0x00e1e1e1;};
+	NodeSet Nature {BuiltIn = 1; Color = 0x00f8eed2;};
+	NodeSet Deterministic {BuiltIn = 1; Color = 0x00d3caa6;};
+	NodeSet Finding {BuiltIn = 1; Color = 0x00c8c8c8;};
+	NodeSet Constant {BuiltIn = 1; Color = 0x00ffffff;};
+	NodeSet ConstantValue {BuiltIn = 1; Color = 0x00ffffb4;};
+	NodeSet Utility {BuiltIn = 1; Color = 0x00ffbdbd;};
+	NodeSet Decision {BuiltIn = 1; Color = 0x00dee8ff;};
+	NodeSet Documentation {BuiltIn = 1; Color = 0x00f0fafa;};
+	NodeSet Title {BuiltIn = 1; Color = 0x00ffffff;};
+	PrinterSetting A {
+		margins = (1270, 1270, 1270, 1270);
+		};
+	};
 user U1 {
 	Hub = "miniPP_CM";
 	Pathname = "PPcompEM.dne";
 	priorWeight = "10";
 	};
 
-param X_NTL_2 {
+param X_POfMom_1 {
 	kind = DISCONNECTED;
 	discrete = TRUE;
 	states = (High, Medium, Low);
 	levels = (0.967421566101701, 0, -0.967421566101701);
-	title = "NTL";
+	title = "POfMom";
 	whenchanged = 1523314216;
 	};
 
-param X_POfMom_1 {
+param X_NTL_2 {
 	kind = DISCONNECTED;
 	discrete = TRUE;
 	states = (High, Medium, Low);
 	levels = (0.967421566101701, 0, -0.967421566101701);
-	title = "POfMom";
+	title = "NTL";
 	whenchanged = 1523314216;
 	};
 
@@ -60,6 +87,18 @@ node CompensatoryObs {
 		lnAlphas = "structure(c(-0.105360515657826, 0.0953101798043249), .Names = c(\"NTL\",  \"POfMom\"))";
 		betas = "0.3";
 		};
+	visual V1 {
+		center = (210, 60);
+		height = 1;
+		link 1 {
+			labelposn = (241, 9, 264, 24);
+			path = ((239, 9), (224, 34));
+			};
+		link 2 {
+			labelposn = (186, 0, 233, 15);
+			path = ((176, 0), (196, 34));
+			};
+		};
 	};
 NodeSet onodes {Nodes = (CompensatoryObs);};
 NodeSet Observables {Nodes = (CompensatoryObs);};