Merge pull request #94 from nutterb/current-devel

Completed Version 0.10.0

.travis.yml

@@ -22,6 +22,9 @@ env:
 r_github_packages:
   - Rexamine/stringi
 
+apt_packages:
+  - libv8-dev
+
 r_packages:
   - rjags
 

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: HydeNet
 Type: Package
 Title: Hybrid Bayesian Networks Using R and JAGS
-Version: 0.9.1
-Date: 2015-07-06
+Version: 0.10.0
+Date: 2015-09-26
 Author: Jarrod E. Dalton <[email protected]> and Benjamin Nutter <[email protected]>
 Maintainer: Benjamin Nutter <[email protected]>
 Description: Facilities for easy implementation of hybrid Bayesian networks
@@ -27,7 +27,7 @@ Depends:
 Imports:
     ArgumentCheck, 
     broom (>= 0.3.7),
-    DiagrammeR (>= 0.7),
+    DiagrammeR (>= 0.8),
     plyr,
     dplyr,
     graph,
@@ -38,7 +38,9 @@ Imports:
     utils
 Suggests:
     knitr,
+    survival,
     testthat
+VignetteBuilder: knitr
 SystemRequirements: JAGS (http://mcmc-jags.sourceforge.net)
 LazyLoad: yes
 LazyData: true

NEWS

@@ -1,8 +1,24 @@
-### 0.9.2 (19 Aug 2015)
+### 0.10.0 (26 Sept 2015)
+* Implements the `factorLevels` element in network objects 
+  and arguments in `setNode`.  See Issue #81
+* Changes to `plot.HydeNetwork` relevant to changes in 
+  `DiagrammeR` 0.8.0.  Note that the column names in custom node
+  data frames no longer contain `node_id` but use `nodes` 
+  instead.  However, the `HydeNet` function arguments have no
+  changed names, in order to maintain compatibility with 0.9.0.
+  Future versions may allow for either `node_id` or `nodes` to 
+  be used.  In custom edge data frames, `edge_from` and `edge_to`
+  are changed to `from` and `to`, respectively.
+
+### 0.9.3 (24 Sept 2015)
+* Minor bug fix related to creating policy matrices with nodes that
+  don't have a 'nodeFitter' specified.
+
+### 0.9.2 (11 Sept 2015)
 * Fixed a bug in `compileJagsModel` and `compileDecisionModel` that prevented `cpt`
   objects from being passed to JAGS models correctly.
 * Added `nodeData` argument to `setNode`.
-* Began writing unit tests.
+* Added unit tests.
 
 ### 0.9.1 (6 July 2015)
 * Conversion of argument checks to using the `ArgumentCheck` package

R/HydeNetwork.R

@@ -49,6 +49,12 @@
 #'   \item \code{nodeData} A named list with the data for each node.  If a node's 
 #'       entry in \code{fromData} is \code{TRUE} and \code{nodeData} is \code{NULL},
 #'       it will look to the \code{data} attribute instead.
+#'   \item \code{factorLevels} If the vector associated with the node is a factor 
+#'       (or character), the levels of the factor are stored here.  Although it
+#'       may seem redundant, it allows factor levels to be specified in cases
+#'       where the node is not define with data.  If data are provided to the 
+#'       node, this element is determined from the data and cannot be 
+#'       manually overwritten.
 #'   \item \code{nodeModel} A list of model objects.  This is a storing place for 
 #'       models that have already been fit so that they don't have to be refit 
 #'       again.
@@ -161,13 +167,23 @@ HydeNetwork.formula <- function(nodes, data=NULL, ...){
   nodeUtility <- lapply(seq_along(node_names), function(x) return(FALSE))
   names(nodeUtility) <- node_names
 
+  factorLevels <- lapply(seq_along(node_names), function(x) return(NULL))
+  names(factorLevels) <- node_names
+  if (!is.null(data)){
+    factor_vars <- names(data)[vapply(data, is.factor, logical(1))]
+    factorLevels[factor_vars] <- 
+      lapply(data[, factor_vars, drop = FALSE],
+             levels)
+  }
+
   #* Define the HydeNetwork object
   network <- list(nodes = node_names, parents=parents, nodeType=nodeType,
                   nodeFormula=nodeFormula,
                   nodeFitter=nodeFitter, nodeFitterArgs=nodeFitterArgs,
                   nodeParams=nodeParams, 
                   fromData=fromData, 
                   nodeData = nodeData,
+                  factorLevels = factorLevels,
                   nodeModel = nodeModel,
                   nodeDecision = nodeDecision,
                   nodeUtility = nodeUtility,
@@ -212,6 +228,7 @@ HydeNetwork.list <- function(nodes, ...){
     network$nodeDecision[[i]] <- Attrs[[i]]$nodeDecision
     network$nodeUtility[[i]] <- Attrs[[i]]$nodeUtility
     network$fromData[[i]] <- TRUE
+    network$factorLevels[[i]] <- Attrs[[i]]$factorLevels
   }
 
   return(network)

R/HydeUtilities.R

@@ -86,16 +86,23 @@ termName <- function(term, reg){
 #' @param network A Hyde Network Object
 
 decisionOptions <- function(node, network){
-  if (network$nodeFitter[[node]] == "cpt"){
-    D <- {if (!is.null(network$nodeData[[node]])) network$nodeData[[node]][[node]] 
-          else network$data[[node]]}
-    dist <- 1:length(unique(D))
+  #* In some cases, nodeFitter isn't set for a node.  When nodeFitter is NULL,
+  #* we want to skip the "cpt" check and move on to other possibilities.
+  #* If it isn't NULL and "cpt" is the fitter, we return dist immediately
+  #* to avoid overwriting it in subsequent checks
+  if (!is.null(network$nodeFitter[[node]])){
+    if (network$nodeFitter[[node]] == "cpt"){
+      D <- {if (!is.null(network$nodeData[[node]])) network$nodeData[[node]][[node]] 
+            else network$data[[node]]}
+      dist <- 1:length(unique(D))
+      return(dist)
+    }
   }
   #* This uses a regular expression to extract the level number from
   #* the node JAGS model.  For instance
   #* pi.var[1] <- .123; pi.var[2] <- .321; ...
   #* the regular expression pulls out the numbers in between each set of [].
-  else if (network$nodeType[[node]] == "dcat"){
+  if (network$nodeType[[node]] == "dcat"){
     dist <- writeJagsModel(network, node)[1]
     dist <- unlist(strsplit(dist, ";"))
     dist <- as.numeric(stringr::str_extract(dist, stringr::regex("(?<=[\\[]).*(?=[\\]])")))
@@ -220,11 +227,20 @@ validateParameters <- function(params, dist){
 #' 
 makeFactorRef <- function(network)
 {
-  dataList <- c(list(network$data), network$nodeData)
-  names(dataList) <- NULL
-  Ref <- do.call("c", lapply(dataList, dataframeFactors))
+  network_factors <- 
+    names(network$factorLevels)[!vapply(network$factorLevels, is.null, logical(1))]
 
-  types <- unlist(network$nodeType[names(Ref)])
+  if (length(network_factors) == 0) return(NULL)
+
+  Ref <- lapply(network_factors,
+         function(f){
+           data.frame(value = 1:length(network$factorLevels[[f]]),
+                      label = network$factorLevels[[f]],
+                      stringsAsFactors = FALSE)
+         })
+  names(Ref) <- network_factors
+
+  types <- unlist(network$nodeType[network_factors])
   types <- types[types %in% "dbern"]
 
   Ref[names(types)] <- 
@@ -233,7 +249,26 @@ makeFactorRef <- function(network)
              f$value <- f$value - 1
              f
            })
+
   Ref[unique(names(Ref))]
+  #* The code below was the old way of doing this
+  #* before we implemented the `factorLevels` element.
+  #* I'm just hesitant to give it up before the 
+  #* new system is well tested.
+#   dataList <- c(list(network$data), network$nodeData)
+#   names(dataList) <- NULL
+#   Ref <- do.call("c", lapply(dataList, dataframeFactors))
+#   
+#   types <- unlist(network$nodeType[names(Ref)])
+#   types <- types[types %in% "dbern"]
+#   
+#   Ref[names(types)] <- 
+#     lapply(Ref[names(types)], 
+#            function(f){
+#              f$value <- f$value - 1
+#              f
+#            })
+#   Ref[unique(names(Ref))]
 }
 
 #' @rdname HydeUtilities

R/bindPosterior.R

@@ -55,17 +55,21 @@ bindPosterior <- function(hydePost, relabel_factor=TRUE){
   else 
     bound <- dplyr::bind_rows(lapply(hydePost$codas, bind_chains_list))
 
-  factors_to_relabel <- names(bound)[names(bound) %in% names(hydePost$factorRef)]
-
-  for(i in factors_to_relabel){
-    bound[i] <- factor(bound[[i]], 
-                       levels=hydePost$factorRef[[i]]$value,
-                       labels=hydePost$factorRef[[i]]$label)
+  if (relabel_factor){
+    factors_to_relabel <- names(bound)[names(bound) %in% names(hydePost$factorRef)]
+    for(i in factors_to_relabel){
+      bound[i] <- factor(bound[[i]], 
+                         levels=hydePost$factorRef[[i]]$value,
+                         labels=hydePost$factorRef[[i]]$label)
+    }
   }
 
   as.data.frame(bound)
 }
 
+
+
+#**** UTILITY FUNCTIONS
 bind_chains_mcmclist <- function(mcmc, hydePost){
   as.data.frame(hydePost$codas[[mcmc]]) %>%
     dplyr::mutate_(chain_index = ~mcmc,