Merge pull request #528 from stan-dev/handle-tables-indata

Handle tables in data

Author: rok-cesnovar

NEWS.md

@@ -20,6 +20,9 @@ to gradients computed via finite differences. (#485)
 so that models do not get unnecessarily recompiled when calling the function
 multiple times with the same code. (#495, @martinmodrak)
 
+* `write_stan_json()` now handles data of class `"table"`. Tables are converted
+to vector, matrix, or array depending on the dimensions of the table. (#528)
+
 # cmdstanr 0.4.0
 
 ### Bug fixes

R/data.R

@@ -11,6 +11,7 @@
 #' * `logical` -> `integer` (`TRUE` -> `1`, `FALSE` -> `0`)
 #' * `data.frame` -> `matrix` (via [data.matrix()])
 #' * `list` -> `array`
+#' * `table` -> `vector`, `matrix`, or `array` (depending on dimensions of table)
 #'
 #' The `list` to `array` conversion is intended to make it easier to prepare
 #' the data for certain Stan declarations involving arrays:
@@ -52,11 +53,20 @@
 #' cat(readLines(file), sep = "\n")
 #'
 write_stan_json <- function(data, file) {
+  if (!is.list(data)) {
+    stop("'data' must be a list.", call. = FALSE)
+  }
   if (!is.character(file) || !nzchar(file)) {
     stop("The supplied filename is invalid!", call. = FALSE)
   }
 
   data_names <- names(data)
+  if (length(data) > 0 &&
+      (length(data_names) == 0 ||
+       length(data_names) != sum(nzchar(data_names)))) {
+    stop("All elements in 'data' list must have names.", call. = FALSE)
+
+  }
   if (anyDuplicated(data_names) != 0) {
     stop("Duplicate names not allowed in 'data'.", call. = FALSE)
   }
@@ -67,8 +77,13 @@ write_stan_json <- function(data, file) {
           is.data.frame(var) || is.list(var))) {
       stop("Variable '", var_name, "' is of invalid type.", call. = FALSE)
     }
+    if (anyNA(var)) {
+      stop("Variable '", var_name, "' has NA values.", call. = FALSE)
+    }
 
-    if (is.logical(var)) {
+    if (is.table(var)) {
+      var <- unclass(var)
+    } else if (is.logical(var)) {
       mode(var) <- "integer"
     } else if (is.data.frame(var)) {
       var <- data.matrix(var)
@@ -136,9 +151,6 @@ process_data <- function(data) {
         call. = FALSE
       )
     }
-    if (any_na_elements(data)) {
-      stop("Data includes NA values.", call. = FALSE)
-    }
     path <- tempfile(pattern = "standata-", fileext = ".json")
     write_stan_json(data = data, file = path)
   } else {
@@ -153,12 +165,6 @@ any_zero_dims <- function(data) {
   any(has_zero_dims)
 }
 
-# check if any objects in the data list contain NAs
-any_na_elements <- function(data) {
-  has_na_elements <- sapply(data, anyNA)
-  any(has_na_elements)
-}
-
 #' Write posterior draws objects to csv files
 #' @noRd
 #' @param draws A `draws_array` from posterior pkg

man/write_stan_json.Rd

@@ -0,0 +1,28 @@
+{
+  "x": [
+    [
+      [5, 0, 0, 0],
+      [0, 0, 0, 0],
+      [0, 0, 0, 0],
+      [0, 0, 0, 0]
+    ],
+    [
+      [0, 0, 0, 0],
+      [0, 5, 0, 0],
+      [0, 0, 0, 0],
+      [0, 0, 0, 0]
+    ],
+    [
+      [0, 0, 0, 0],
+      [0, 0, 0, 0],
+      [0, 0, 5, 0],
+      [0, 0, 0, 0]
+    ],
+    [
+      [0, 0, 0, 0],
+      [0, 0, 0, 0],
+      [0, 0, 0, 0],
+      [0, 0, 0, 5]
+    ]
+  ]
+}

tests/testthat/answers/json-table-array.json

@@ -0,0 +1,8 @@
+{
+  "x": [
+    [5, 0, 0, 0],
+    [0, 5, 0, 0],
+    [0, 0, 5, 0],
+    [0, 0, 0, 5]
+  ]
+}

tests/testthat/answers/json-table-matrix.json

@@ -0,0 +1,3 @@
+{
+  "x": [5, 5, 5, 5]
+}

tests/testthat/answers/json-table-vector.json

@@ -11,13 +11,6 @@ test_that("empty data list converted to NULL", {
   expect_null(process_data(list()))
 })
 
-test_that("NAs detected in data list", {
-  expect_false(any_na_elements(list(y = 1)))
-  expect_true(any_na_elements(list(y = 1, N = NA)))
-  expect_true(any_na_elements(list(x = matrix(NA, 1, 1))))
-  expect_true(any_na_elements(list(x = list(1, NA))))
-})
-
 test_that("process_fitted_params() works with basic input types", {
   temp_file <- tempfile()
   temp_files <- c(tempfile(),

tests/testthat/test-data.R

@@ -76,19 +76,62 @@ test_that("JSON output for list of matrices is correct", {
                       file = test_path("answers", "json-matrix-lists.json"))
 })
 
-test_that("write_stan_json() throws correct errors", {
-  skip_on_cran()
+test_that("JSON output for table is correct", {
   temp_file <- tempfile()
+  f <- factor(rep(1:4, each = 5))
 
+  write_stan_json(list(x = table(f)), file = temp_file)
+  json_output <- readLines(temp_file)
+  expect_known_output(cat(json_output, sep = "\n"),
+                      file = test_path("answers", "json-table-vector.json"))
+
+  write_stan_json(list(x = table(f, f)), file = temp_file)
+  json_output <- readLines(temp_file)
+  expect_known_output(cat(json_output, sep = "\n"),
+                      file = test_path("answers", "json-table-matrix.json"))
+
+  write_stan_json(list(x = table(f, f, f)), file = temp_file)
+  json_output <- readLines(temp_file)
+  expect_known_output(cat(json_output, sep = "\n"),
+                      file = test_path("answers", "json-table-array.json"))
+})
+
+test_that("write_stan_json errors if NAs", {
+  expect_error(
+    write_stan_json(list(y = 1, N = NA), tempfile()),
+    "Variable 'N' has NA values"
+  )
+  expect_error(
+    write_stan_json(list(x = matrix(NA, 1, 1)), tempfile()),
+    "Variable 'x' has NA values"
+  )
   expect_error(
-    write_stan_json(list(N = c(1.0, 2.0, 3, 4)), file = c(1,2)),
+    write_stan_json(list(x = list(1, NA)), tempfile()),
+    "Variable 'x' has NA values"
+  )
+})
+
+test_that("write_stan_json() errors if data is not a list", {
+  expect_error(
+    write_stan_json(1:10),
+    "'data' must be a list"
+  )
+})
+
+test_that("write_stan_json() errors if bad filename", {
+  temp_file <- tempfile()
+
+  expect_error(
+    write_stan_json(list(N = 10), file = c(1,2)),
     "The supplied filename is invalid!"
   )
   expect_error(
-    write_stan_json(list(N = N), file = ""),
+    write_stan_json(list(N = 10), file = ""),
     "The supplied filename is invalid!"
   )
+})
 
+test_that("write_stan_json() errors if vectors/matrices in same list are different sizes", {
   expect_error(
     write_stan_json(list(N = list(c(26, 26, 26), c(26, 26))), file = "abc.txt"),
     "All matrices/vectors in list 'N' must be the same size!"
@@ -109,7 +152,9 @@ test_that("write_stan_json() throws correct errors", {
     write_stan_json(list(N = list(matrix(1:8, ncol = 2), matrix(1:9, ncol = 3))), file = "abc.txt"),
     "All matrices/vectors in list 'N' must be the same size!"
   )
+})
 
+test_that("write_stan_json() errors if invalid types", {
   expect_error(
     write_stan_json(list(N = list("abc", "def")), file = "abc.txt"),
     "All elements in list 'N' must be numeric!"
@@ -119,9 +164,21 @@ test_that("write_stan_json() throws correct errors", {
     write_stan_json(list(N = "STRING"), file = "abc.txt"),
     "Variable 'N' is of invalid type"
   )
+})
 
+test_that("write_stan_json() errors if bad names", {
   expect_error(
     write_stan_json(list(x = 1, y = 2, x = 3), file = tempfile()),
     "Duplicate names not allowed in 'data'"
   )
+
+  expect_error(
+    write_stan_json(list(1, 2), tempfile()),
+    "All elements in 'data' list must have names"
+  )
+
+  expect_error(
+    write_stan_json(list(a = 1, 2), tempfile()),
+    "All elements in 'data' list must have names"
+  )
 })

tests/testthat/test-json.R

@@ -42,9 +42,9 @@ test_that("error if data contains NA elements", {
   data_list2$y[3] <- NA
   data_list3$X[3, 2] <- NA
 
-  expect_error(mod$sample(data = data_list1), "Data includes NA values")
-  expect_error(mod$sample(data = data_list2), "Data includes NA values")
-  expect_error(mod$sample(data = data_list3), "Data includes NA values")
+  expect_error(mod$sample(data = data_list1), "Variable 'N' has NA values")
+  expect_error(mod$sample(data = data_list2), "Variable 'y' has NA values")
+  expect_error(mod$sample(data = data_list3), "Variable 'X' has NA values")
 })
 
 test_that("empty data list doesn't error if no data block", {