Upper case tagged NA values when writing XPT files

NEWS.md

@@ -1,5 +1,7 @@
 # haven (development version)
 
+* Fix bug that caused `write_xpt()` to fail when writing tagged `NA` values (#755).
+
 # haven 2.5.5
 
 * Updated ReadStat to fix stricter gcc diagnostics.

R/haven-sas.R

@@ -93,8 +93,11 @@ write_sas <- function(data, path) {
 
 #' Read and write SAS transport files
 #'
-#' The SAS transport format is a open format, as is required for submission
-#' of the data to the FDA.
+#' The SAS transport format is an open format, as is required for submission
+#' of data to the FDA.
+#'
+#' Value labels are not supported by the transport format, and are silently
+#' ignored by `write_xpt()`.
 #'
 #' @inheritParams read_spss
 #' @return A tibble, data frame variant with nice defaults.
@@ -104,7 +107,7 @@ write_sas <- function(data, path) {
 #'
 #'   If a dataset label is defined, it will be stored in the "label" attribute
 #'   of the tibble.
-#'
+#' 
 #'   `write_xpt()` returns the input `data` invisibly.
 #' @export
 #' @examples

src/DfWriter.cpp

@@ -326,6 +326,9 @@ class Writer {
         if (!std::isnan(values[i]) || tag == '\0') {
           readstat_label_double_value(labelSet, values[i], string_utf8(labels, i));
         } else {
+          if (ext_ == HAVEN_XPT || ext_ == HAVEN_SAS7BDAT || ext_ == HAVEN_SAS7BCAT) {
+            tag = toupper(tag);
+          }
           readstat_label_tagged_value(labelSet, tag, string_utf8(labels, i));
         }
       }
@@ -448,6 +451,9 @@ class Writer {
       if (tag == '\0') {
         return readstat_insert_missing_value(writer_, var);
       } else {
+        if (ext_ == HAVEN_XPT || ext_ == HAVEN_SAS7BDAT || ext_ == HAVEN_SAS7BCAT) {
+          tag = toupper(tag);
+        }
         return readstat_insert_tagged_missing_value(writer_, var, tag);
       }
     } else {

tests/testthat/test-haven-sas.R

@@ -188,6 +188,18 @@ test_that("can roundtrip date times", {
   expect_equal(attr(roundtrip_var(x2, "xpt"), "label"), "abc")
 })
 
+test_that("can roundtrip tagged NAs", {
+  x <- c(1, 2, tagged_na("a", "b"), NA)
+  expect_equal(roundtrip_var(x, "dta"), x)
+
+  tags <- tagged_na("a", "b")
+  y <- labelled(
+    x,
+    c("ABC" = tags[1], "DEF" = tags[2])
+  )
+  expect_equal(roundtrip_var(y, "xpt"), x)
+})
+
 test_that("invalid files generate informative errors", {
   expect_snapshot(error = TRUE, {
     write_xpt(mtcars, file.path(tempdir(), " temp.xpt"))