Update tests to use new process_input

4 files changed, 253 insertions, 39 deletions

diff --git a/.Rbuildignore b/.Rbuildignore
index e9ca541..8315df6 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -12,3 +12,4 @@ README.md
 env.R
 .travis.yml
 ^\.github$
+Makefile
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..e30a6c4
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,21 @@
+NAME = $(shell grep 'Package:' DESCRIPTION | cut -d ' ' -f2)
+VER = $(shell grep 'Version:' DESCRIPTION | cut -d ' ' -f2)
+
+install:
+	R CMD INSTALL .
+
+build:
+	cd ..; R CMD build $(NAME)
+
+check:
+	make build
+	cd ..; R CMD check $(NAME)_$(VER).tar.gz
+
+test:
+	make install
+	Rscript -e "tinytest::test_package('jagsUI')"
+
+coverage:
+	make install
+	Rscript -e 'covr::report(file="/tmp/jagsUI-report.html")'
+	firefox /tmp/jagsUI-report.html
diff --git a/R/process_input.R b/R/process_input.R
new file mode 100644
index 0000000..c3f219d
--- /dev/null
+++ b/R/process_input.R
@@ -0,0 +1,153 @@
+# Process input----------------------------------------------------------------
+process_input <- function(data, params, inits, n_chains, n_adapt, n_iter, n_burnin,
+                          n_thin, n_cores, DIC, quiet, parallel){
+  
+  if(!quiet){cat('\nProcessing function input.......','\n')}
+  out <- list(data = check_data(data, quiet),
+              params = check_params(params, DIC),
+              n.cores = check_cores(n_cores, n_chains, parallel),
+              inits = check_inits(inits, n_chains),
+              mcmc.info = check_mcmc_info(n_chains, n_adapt, n_iter, n_burnin, 
+                                          n_thin)
+  )
+  if(!quiet){cat('\nDone.','\n','\n')}
+  out
+}
+
+
+# Check data list--------------------------------------------------------------
+check_data <- function(inp_data, quiet){
+  # Check data is a list
+  if(!is.list(inp_data)){
+    stop("Input data must be a list", call.=FALSE)
+  }
+  # Check list is named
+  nms <- names(inp_data)
+  if(is.null(nms) || any(nms == "")){
+    stop("All elements of the input data list must be named", call.=FALSE)
+  }
+  
+  # Check individual data elements
+  out <- lapply(1:length(inp_data), function(i){
+    check_data_element(inp_data[[i]], nms[i], quiet)
+  })
+  names(out) <- nms
+  out
+}
+
+
+# Check individual data elements-----------------------------------------------
+check_data_element <- function(x, name, quiet){
+  # Stop if element is a factor
+  if(is.factor(x)){
+    stop("Element", name, "is a factor. Convert it to numeric.", call.=FALSE)
+  }
+  # Try to convert data frame to matrix/vector
+  if(is.data.frame(x)){
+    # Old versions attempted to convert a 1-column data frame to vector
+    # but did it incorrectly (always converted to matrix).
+    # This behavior was preserved here.
+    x <- as.matrix(x)
+    if(!is.numeric(x)){
+      stop("Could not convert data.frame ", name, " to numeric matrix", call.=FALSE)
+    }
+    if(!quiet) cat("\nConverted data.frame", name, "to matrix\n")
+  }
+  # Final check if element is numeric
+  if(!is.numeric(x)){
+    stop("Element ", name, " is not numeric", call.=FALSE)
+  }
+  x
+}
+
+
+# Check parameter vector-------------------------------------------------------
+check_params <- function(params, DIC){
+  if(!(is.vector(params) & is.character(params))){
+    stop("parameters.to.save must be a character vector", call.=FALSE)
+  }
+  if(DIC & (! "deviance" %in% params)){
+    params <- c(params, "deviance")
+  }
+  params
+}
+
+
+# Check mcmc settings----------------------------------------------------------
+#names(mcmc.info) <- c('n.chains','n.adapt','sufficient.adapt','n.iter','n.burnin','n.thin','n.samples','end.values','elapsed.mins')
+
+check_mcmc_info <- function(n_chains, n_adapt, n_iter, n_burnin, 
+                            n_thin, n_cores, parallel){
+
+  if(n_iter <= n_burnin){
+    stop("Number of iterations must be larger than burn-in", call.=FALSE)
+  }
+  # Removed warnings about small numbers of iterations and uneven iterations
+  
+  # Create list structure and save available elements
+  list(n.chains = n_chains, n.adapt = n_adapt, sufficient_adapt = NA,
+       n.iter = n_iter, n.burnin = n_burnin, n.thin = n_thin,
+       n.samples = NA, end.values = NA, elapsed.mins = NA)
+}
+
+
+# Check number of cores--------------------------------------------------------
+check_cores <- function(n_cores, n_chains, parallel){
+  if(!parallel) return(NULL)
+  max_cores <- parallel::detectCores()
+  # Send this warning right away
+  old_warn <- options()$warn
+  options(warn=1)
+  if(!is.null(n_cores)){
+    if(n_cores > max_cores){
+      n_cores <- max_cores
+      warning("n.cores > max available cores. n.cores set to ", max_cores, 
+              call.=FALSE)
+    }
+  } else {
+    if(!is.na(max_cores)){
+      n_cores <- min(max_cores, n_chains)
+    } else {
+      warning("Couldn't detect number of cores. Setting n.cores = n.chains", 
+            call.=FALSE)
+      n_cores <- n_chains
+    }  
+  }
+  options(warn=old_warn)
+  n_cores
+}
+
+
+# Check initial values---------------------------------------------------------
+check_inits <- function(inits, n_chains){
+  if(is.list(inits)){
+    if(length(inits) != n_chains){
+      stop("inits list must have length equal to the number of chains",
+           call.=FALSE)
+    }
+  } else if(is.function(inits)){
+    test <- inits()
+    if(!is.list(test)){
+      stop("inits function must return list", call.=FALSE)
+    }
+    inits <- lapply(1:n_chains, function(x) inits())
+  } else if(is.null(inits)){
+    inits <- vector("list", n_chains)
+  } else {
+    stop("inits must be a list or a function that returns a list", call.=FALSE)
+  }
+
+  # Setup seeds in each chain, for reproducibility
+  # Check if they already exist
+  has_RNG <- all(c(".RNG.name",".RNG.seed") %in% names(inits[[1]]))
+  # If not add them
+  if(!has_RNG){
+    # Generate random seeds for each chain
+    chain_seeds <- floor(runif(n_chains, 1, 100000))
+    for (i in 1:n_chains){
+      inits[[i]]$.RNG.name="base::Mersenne-Twister"
+      inits[[i]]$.RNG.seed=chain_seeds[i]
+    }
+  }
+  inits
+}
diff --git a/inst/tinytest/test_input_processing.R b/inst/tinytest/test_input_processing.R
index d48c7bc..28f479a 100644
--- a/inst/tinytest/test_input_processing.R
+++ b/inst/tinytest/test_input_processing.R
@@ -1,46 +1,75 @@
-gen.inits <- jagsUI:::gen.inits
-process.input <- jagsUI:::process.input
+process_input <- jagsUI:::process_input
+check_inits <- jagsUI:::check_inits
 
+# Overall structure------------------------------------------------------------
+data1 <- list(a=1, b=c(1,2), c=matrix(rnorm(4), 2,2), 
+              d=array(rnorm(8), c(2,2,2)), e=c(NA, 1))
+test <- process_input(data1, params="a", NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE)
+expect_inherits(test, "list")
+expect_equal(names(test), c("data", "params", "n.cores", "inits", "mcmc.info"))
 
 # Data processing--------------------------------------------------------------
 # Stuff that gets passed through unchanged
 data1 <- list(a=1, b=c(1,2), c=matrix(rnorm(4), 2,2), 
               d=array(rnorm(8), c(2,2,2)), e=c(NA, 1))
-test <- process.input(data1, "a", NULL, 2, 100, 50, 2, NULL, verbose=FALSE)
+test <- process_input(data1, params="a", NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE)
 expect_identical(test$data, data1)
 
+# Data frame handling
 data2 <- list(a=data.frame(v1=c(1,2)), b=data.frame(v1=c(0,1), v2=c(2,3)))
-co <- capture.output(test <- process.input(data2, "a", NULL, 2, 100, 50, 2, NULL))
-ref_msg <- c("", "Processing function input....... ", "", "Converting data frame 'a' to matrix.","", "Converting data frame 'b' to matrix.", "", "Done. ", " ")
+co <- capture.output(
+test <- process_input(data2, params="a", NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=FALSE, parallel=FALSE)
+)
+ref_msg <- c("", "Processing function input....... ", "", 
+             "Converted data.frame a to matrix","", 
+             "Converted data.frame b to matrix", "", "Done. ", " ")
 expect_equal(co, ref_msg)
 expect_equivalent(test$data, list(a=matrix(c(1,2), ncol=1),
                                   b=matrix(c(0:3), ncol=2)))
 
+# non-numeric data frame errors
+data2$v3 <- data.frame(v1=c("a","b"))
+expect_error(process_input(data2, params="a", NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE))
+
 # Factor in data
 data3 <- list(a=1, b=factor(c("1","2")))
-expect_error(process.input(data3, "a", NULL, 2, 100, 50, 2, NULL, verbose=FALSE))
+expect_error(process_input(data3, params="a", NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE))
 
 # Character in data
 data4 <- list(a=1, b=c("a","b"))
-expect_error(process.input(data4, "a", NULL, 2, 100, 50, 2, NULL, verbose=FALSE))
+expect_error(process_input(data4, params="a", NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE))
 
 # Vector with attributes is allowed
-#vec <- c(1,2)
-#attr(vec, "test") <- "test"
-#expect_false(is.vector(vec))
-#data5 <- list(vec=vec)
-#test <- process.input(data5, "a", NULL, 2, 100, 50, 2, NULL, verbose=FALSE)
-#expect_equal(data5, test$data5)
+vec <- c(1,2)
+attr(vec, "test") <- "test"
+expect_false(is.vector(vec))
+data5 <- list(vec=vec)
+test <- process_input(data5, params="a", NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE)
+expect_equal(data5, test$data)
 
 # One-column matrix is not converted to vector
 data6 <- list(a=matrix(c(1,2), ncol=1))
-test <- process.input(data6, "a", NULL, 2, 100, 50, 2, NULL, verbose=FALSE)
+test <- process_input(data6, params="a", NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE)
 expect_equal(test$data, data6)
 
 # Non-list as input errors
-#t1 <- 1; t2 <- 2
-#data7 <- c("t1", "t2")
-#expect_error(process.input(data7, "a", NULL, 2, 100, 50, 2, NULL, verbose=FALSE))
+t1 <- 1; t2 <- 2
+data7 <- c("t1", "t2")
+expect_error(process_input(data7, params="a", NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE))
+
+# List without names as input errors
+data8 <- list(1, 2)
+expect_error(process_input(data8, params="a", NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE))
 
 
 # Parameter vector processing--------------------------------------------------
@@ -49,39 +78,43 @@ pars1 <- c("a", "b")
 pars2 <- c("deviance","a", "b")
 
 # DIC = FALSE
-test <- process.input(dat, pars1, NULL, 2, 100, 50, 2, NULL, verbose=FALSE)
+test <- process_input(dat, params=pars1, NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=FALSE, quiet=TRUE, parallel=FALSE)
 expect_equal(pars1, test$params)
 
 # DIC = TRUE
-test <- process.input(dat, pars1, NULL, 2, 100, 50, 2, NULL, verbose=FALSE, DIC=TRUE)
+test <- process_input(dat, params=pars1, NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE)
 expect_equal(c(pars1, "deviance"), test$params)
 
 # Deviance already in vector
-test <- process.input(dat, pars2, NULL, 2, 100, 50, 2, NULL, verbose=FALSE, DIC=TRUE)
+test <- process_input(dat, params=pars2, NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=TRUE, quiet=TRUE, parallel=FALSE)
 expect_equal(pars2, test$params)
 
 # Incorrect format
-expect_error(process.input(dat, c(1,2), NULL, 2, 100, 50, 2, NULL, verbose=FALSE))
+expect_error(process_input(dat, params=c(1,2), NULL, 2, 1, 100, 50, 2, 
+                      NULL, DIC=FALSE, quiet=TRUE, parallel=FALSE))
 
 
 # MCMC info processing---------------------------------------------------------
 dat <- list(a=1, b=2)
 pars1 <- c("a", "b")
 # n.iter/n.burnin mismatch
-expect_error(process.input(dat, pars1, NULL, 2, n.iter=100, n.burnin=100, 
-                      2, NULL, verbose=FALSE, DIC=TRUE))
-expect_error(process.input(dat, pars1, NULL, 2, n.iter=100, n.burnin=150, 
-                      2, NULL, verbose=FALSE, DIC=TRUE))
+expect_error(process_input(dat, params=pars1, NULL, 2, 1, n_iter=100, n_burnin=100, 2, 
+                      NULL, DIC=FALSE, quiet=TRUE, parallel=FALSE))
+expect_error(process_input(dat, params=pars1, NULL, 2, 1, n_iter=100, n_burnin=150, 2, 
+                      NULL, DIC=FALSE, quiet=TRUE, parallel=FALSE))
 
 # n.cores
 # when parallel=FALSE
-test <- process.input(dat, pars1, NULL, 2, n.iter=100, n.burnin=50, 
-                      2, NULL, verbose=FALSE, DIC=TRUE)
+test <- process_input(dat, params=pars1, NULL, 2, 1, n_iter=100, n_burnin=50, 2, 
+                      n_cores=NULL, DIC=FALSE, quiet=TRUE, parallel=FALSE)
 expect_true(is.null(test$n.cores))
 
 # when parallel=TRUE defaults to min of nchains and ncores
-test <- process.input(dat, pars1, NULL, 2, n.iter=100, n.burnin=50, 
-                      2, NULL, verbose=FALSE, DIC=TRUE, parallel=TRUE)
+test <- process_input(dat, params=pars1, NULL, 2, 1, n_iter=100, n_burnin=50, 2, 
+                      n_cores=NULL, DIC=FALSE, quiet=TRUE, parallel=TRUE)
 expect_equal(test$n.cores, 2)
 
 avail_cores <- parallel::detectCores()
@@ -89,8 +122,10 @@ if(avail_cores > 1){
   try_cores <- avail_cores + 1
   n_chain <- try_cores
   expect_warning(nul <- capture.output(
-    test <- process.input(dat, pars1, NULL, n.chains=n_chain, n.iter=100, n.burnin=50, 
-    n.thin=2, verbose=TRUE, DIC=TRUE, parallel=TRUE, n.cores=try_cores)))
+  test <- process_input(dat, params=pars1, NULL, n_chains=n_chain, 1, 
+                        n_iter=100, n_burnin=50, 2, 
+                      n_cores=try_cores, DIC=FALSE, quiet=TRUE, parallel=TRUE)
+  ))
   expect_equal(test$n.cores, avail_cores)
 }
 
@@ -100,31 +135,32 @@ inits2 <- list(list(a=1, b=2), list(a=3, b=4))
 inits3 <- list(a=1, b=2)
 inits4 <- function() list(a=1, b=2)
 inits5 <- function() list()
-inits6 <- 1
+inits6 <- function() 1
+inits7 <- 1
 
 # No inits provided
 set.seed(123)
-test <- gen.inits(inits1, seed=NULL, n.chains=2)
+test <- check_inits(inits1, n_chains=2)
 ref <- list(list(.RNG.name = "base::Mersenne-Twister", .RNG.seed = 28758),
     list(.RNG.name = "base::Mersenne-Twister", .RNG.seed = 78830))
 expect_identical(test, ref)
 
 # A list of lists
 set.seed(123)
-test <- gen.inits(inits2, seed=NULL, n.chains=2)
+test <- check_inits(inits2, n_chains=2)
 ref <- list(list(a = 1, b = 2, .RNG.name = "base::Mersenne-Twister",
     .RNG.seed = 28758), list(a = 3, b = 4, .RNG.name = "base::Mersenne-Twister",
     .RNG.seed = 78830))
 expect_identical(test, ref)
 # Wrong number of list elements for number of chains
-expect_error(gen.inits(inits2, seed=NULL, n.chains=3))
+expect_error(check_inits(inits2, n_chains=3))
 
 # A single list
-expect_error(gen.inits(inits3, seed=NULL, n.chains=1))
+expect_error(check_inits(inits3, n_chains=1))
 
 # A function
 set.seed(123)
-test <- gen.inits(inits4, seed=NULL, n.chains=2)
+test <- check_inits(inits4, n_chains=2)
 ref <- list(list(a = 1, b = 2, .RNG.name = "base::Mersenne-Twister",
     .RNG.seed = 28758), list(a = 1, b = 2, .RNG.name = "base::Mersenne-Twister",
     .RNG.seed = 78830))
@@ -132,10 +168,13 @@ expect_identical(test, ref)
 
 # An empty list
 set.seed(123)
-test <- gen.inits(inits5, seed=NULL, n.chains=2)
+test <- check_inits(inits5, n_chains=2)
 ref <- list(list(.RNG.name = "base::Mersenne-Twister", .RNG.seed = 28758),
     list(.RNG.name = "base::Mersenne-Twister", .RNG.seed = 78830))
 expect_identical(test, ref)
 
+# Function but doesn't return list
+expect_error(check_inits(inits6, n_chains=2))
+
 # A number
-expect_error(gen.inits(inits6, seed=NULL, n.chains=2))
+expect_error(check_inits(inits7, n_chains=2))