Merge remote-tracking branch 'origin/current-devel' into current-devel

Conflicts:
	DESCRIPTION
	NEWS

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: HydeNet
 Type: Package
 Title: Hybrid Bayesian Networks Using R and JAGS
-Version: 0.10.0
-Date: 2015-10-11
+Version: 0.10.1
+Date: 2015-10-30
 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

NAMESPACE

@@ -33,6 +33,7 @@ export(cpt)
 export(customNode)
 export(expectedParameters)
 export(expectedVariables)
+export(factorFormula)
 export(fromData)
 export(fromFormula)
 export(inputCPT)
@@ -68,6 +69,7 @@ importFrom(stats,terms)
 importFrom(stats,update)
 importFrom(stringr,perl)
 importFrom(stringr,str_extract)
+importFrom(stringr,str_extract_all)
 importFrom(stringr,str_split_fixed)
 importFrom(stringr,str_trim)
 importFrom(utils,tail)

NEWS

@@ -1,4 +1,11 @@
-### 0.10.0 (11 Oct 2015)
+### 0.10.1 (30 October 2015)
+* Corrected a serious bug in how character values were handled in the 
+  `data` argument of `compileDecisionModel`.
+* Adds `factorFormula` to assist in writing formulae that make use 
+  of factor levels instead of their numeric codes.
+
+### 0.10.0 (26 Sept 2015)
+>>>>>>> origin/current-devel
 * Implements the `factorLevels` element in network objects 
   and arguments in `setNode`.  See Issue #81
 * Changes to `plot.HydeNetwork` relevant to changes in 

R/compileDecisionModel.R

@@ -75,19 +75,14 @@ compileDecisionModel <- function(network, policyMatrix = NULL, ..., data = NULL)
 
   dots <- list(...)
 
-#   if ("data" %in% names(dots))
-#     ArgumentCheck::addError(
-#       msg = "'data' is not an accepted argument in 'compileDecisionModel'",
-#       argcheck = Check)
-#  
   options <- makePolicyMatrix(network, policyMatrix, data, Check)
 
   ArgumentCheck::finishArgCheck(Check)
 
   cpt_arrays <- makeCptArrays(network)
 
   jags.code <- compileJagsModel(network, ...)
-  
+
   lapply(options,
          runJagsDecisionModel,
          jags.code,
@@ -166,9 +161,7 @@ makePolicyMatrix <- function(network, policyMatrix, data, argcheck){
                     function(i){ 
                       l <- as.list(options[i, , drop=FALSE])
                       nms <- names(l)
-                      if (is.character(unlist(l)))
-                        l <- as.list(as.character(l))
-                      else l <- as.list(as.numeric(l))
+                      attributes(l) <- NULL
                       names(l) <- nms
                       l
                     })
@@ -210,6 +203,12 @@ makeCptArrays <- function(network){
 runJagsDecisionModel <- function(o, j, cpt_arrays, ...){
   con <- textConnection(paste0(j$jags$model(),
                                  collapse="\n"))
+  o_character <- vapply(o, is.character, logical(1))
+  for (i in seq_along(o)){
+    if (o_character[i])
+      o[[i]] <- j$factorRef[[names(o[i])]]$value[j$factorRef[[names(o[i])]]$label == o[[i]]]
+  }
+
   cHN <- list(jags = rjags::jags.model(con,
                                        data = c(o, cpt_arrays),
                                        ...),

R/factorFormula.R

@@ -0,0 +1,101 @@
+#' @name factorFormula
+#' @export factorFormula
+#' @importFrom stringr str_extract_all
+#' @importFrom stringr str_split_fixed
+#' 
+#' @title Convert Factor Levels in Formula to Numeric Values
+#' @description When working in R, it is often more convenient to work in
+#'   terms of the factor labels rather than the underlying numeric values.
+#'   JAGS, however, requires that the numeric values be used.  
+#'   \code{factorFormula} permits the user to define formulae to be passed
+#'   to JAGS using R style coding, and having factor levels translated 
+#'   to the underlying values as determined by the network structure.
+#'   
+#' @param form A formula object.
+#' @param network A \code{HydeNetwork} object.
+#' 
+#' @details It is assumed that factor variables will be used in logical
+#'   comparisons of the format \code{[variable_name] == '[factor_level]'} and
+#'   only this pattern is recognized in the text search.  Single or 
+#'   double quotes may be used around the level, and the spaces aroudn the
+#'   \code{==} are optional.  
+#'   
+#'   While there are certainly limitations to this function that we have
+#'   not yet found, we believe it covers the majority of cases in which
+#'   it is useful. More complex cases that can't be handled by 
+#'   \code{factorFormula} may require writing native JAGS code.
+#'   
+#' @author Jarrod Dalton and Benjamin Nutter
+#' 
+#' @examples 
+#' Net <- HydeNetwork(~ wells +
+#'                     pe | wells +
+#'                     d.dimer | pregnant*pe +
+#'                     angio | pe +
+#'                     treat | d.dimer*angio +
+#'                     death | pe*treat,
+#'                   data = PE)
+#' factorFormula(form = payoff ~ (death == 'No') + (pe == 'Yes'),
+#'               network = Net)
+#' 
+factorFormula <- function(form, network){
+  form <- deparse(form)
+
+  relabel <- extractFactors(form)
+
+  relabel_mat <- isolateVariableFromLabel(relabel)
+
+  new_label <- 
+    mapply(getNumericLevel, 
+           varname = relabel_mat[, 1], 
+           label = relabel_mat[, 2],
+           nodeType = relabel_mat[, 3],
+           MoreArgs = list(network = network))
+
+  form <- rewriteFormula(relabel, new_label, form)
+
+  as.formula(form)
+}
+
+extractFactors <- function(form){
+  #* This pattern looks for any combination of numbers, letters, 
+  #* periods or underscores, 
+  #* followed by a space (or not), 
+  #* followed by ==
+  #* followed by a space (or not)
+  #* followed by a quote (single or double)
+  #* followed by any character string
+  #* followed by a quote (single or double)
+  #* It is intened to catch a [variable_name] == [factor_level]
+  relabel <- 
+    stringr::str_extract_all(string = form, 
+        pattern = "[[:alpha:],[0-9],[.],[_]]+( |)[=][=]( |)('|\").*?('|\")")
+  unlist(relabel)
+}
+
+isolateVariableFromLabel <- function(relabel){
+  relabel_mat <- stringr::str_split_fixed(relabel, "[=][=]", 2)
+  relabel_mat <- trimws(relabel_mat)
+  relabel_mat <- gsub("('|\")", "", relabel_mat)
+  cbind(relabel_mat,
+        unlist(network$nodeType[relabel_mat[, 1]]))
+}
+
+getNumericLevel <- function(varname, label, nodeType, network){
+  value <- which(network$factorLevels[[varname]] == label)
+  if (nodeType == "dbern") value <- as.numeric(value) - 1
+  as.character(value)
+}
+
+rewriteFormula <- function(relabel, new_label, form){
+  for (i in seq_along(relabel)){
+    new_label[i] <- sub("(?<=('|\")).*?(?=('|\"))", 
+                        new_label[i], 
+                        relabel[i], 
+                        perl = TRUE)
+    new_label[i] <- gsub("('|\")", "", new_label[i])
+    form <- sub(relabel[i], new_label[i], form)
+  }
+  form
+}
+

R/zzz.R

@@ -5,7 +5,7 @@
   options(Hyde_plotOptions = 
     data.frame(type = c("variable", "determ", "decision", "utility"),
                fillcolor = c("white", "white", "#6BAED6", "#FFFFB2"),
-               shape = c("ellipse", "ellipse", "rect", "rect"),
+               shape = c("ellipse", "ellipse", "rect", "diamond"),
                fontcolor = c("black", "gray70", "black", "black"),
                color = c("black", "gray70", "black", "black"),
                style = c("filled", "filled", "filled", "filled"),

man/factorFormula.Rd

@@ -0,0 +1,48 @@
+% Generated by roxygen2 (4.1.1): do not edit by hand
+% Please edit documentation in R/factorFormula.R
+\name{factorFormula}
+\alias{factorFormula}
+\title{Convert Factor Levels in Formula to Numeric Values}
+\usage{
+factorFormula(form, network)
+}
+\arguments{
+\item{form}{A formula object.}
+
+\item{network}{A \code{HydeNetwork} object.}
+}
+\description{
+When working in R, it is often more convenient to work in
+  terms of the factor labels rather than the underlying numeric values.
+  JAGS, however, requires that the numeric values be used.
+  \code{factorFormula} permits the user to define formulae to be passed
+  to JAGS using R style coding, and having factor levels translated
+  to the underlying values as determined by the network structure.
+}
+\details{
+It is assumed that factor variables will be used in logical
+  comparisons of the format \code{[variable_name] == '[factor_level]'} and
+  only this pattern is recognized in the text search.  Single or
+  double quotes may be used around the level, and the spaces aroudn the
+  \code{==} are optional.
+
+  While there are certainly limitations to this function that we have
+  not yet found, we believe it covers the majority of cases in which
+  it is useful. More complex cases that can't be handled by
+  \code{factorFormula} may require writing native JAGS code.
+}
+\examples{
+Net <- HydeNetwork(~ wells +
+                    pe | wells +
+                    d.dimer | pregnant*pe +
+                    angio | pe +
+                    treat | d.dimer*angio +
+                    death | pe*treat,
+                  data = PE)
+factorFormula(form = payoff ~ (death == 'No') + (pe == 'Yes'),
+              network = Net)
+}
+\author{
+Jarrod Dalton and Benjamin Nutter
+}
+

tests/testthat/test-factorFormula.R

@@ -0,0 +1,16 @@
+context("factorFormula")
+
+test_that("factorFormula",
+{
+  Net <- HydeNetwork(~ wells +
+                       pe | wells +
+                       d.dimer | pregnant*pe +
+                       angio | pe +
+                       treat | d.dimer*angio +
+                       death | pe*treat,
+                     data = PE)
+  expect_equal(factorFormula(death ~ ilogit((treat == "No") + (angio == "Positive")),
+                             Net),
+               death ~ ilogit((treat == 0) + (angio == 2)))
+})
+

vignettes/DecisionNetworks.Rmd

@@ -285,7 +285,7 @@ Alternatively, decision nodes can be deterministic in nature. In this case, we i
 
 ```{r}
 net <- setNode(net, payoff, "determ", define=fromFormula(),
-         nodeFormula = payoff ~
+         nodeFormula = factorFormula(payoff ~
                          ifelse(playerFinalPoints > 21, -1,
                            ifelse(playerFinalPoints == 21,
                              ifelse(dealerOutcome == 1, 0,
@@ -304,7 +304,7 @@ net <- setNode(net, payoff, "determ", define=fromFormula(),
                                      ifelse(dealerOutcome == 6,
                                        ifelse(playerFinalPoints == 20, 0,
                                          ifelse(playerFinalPoints > 20, 1, -1)),
-                                       ifelse(playerFinalPoints == 21, 0, -1)))))))))
+                                       ifelse(playerFinalPoints == 21, 0, -1))))))))))
 
 ```