add to_string() to convert variables with labels attribute

NEWS.md

@@ -8,6 +8,8 @@
 
 * The handling of `fmt_txt()` objects has been improved. It now creates objects of class `fmt_txt` with their own `print()`, `+`, and `as.character()` methods. Such objects can now also be used as `text` in `create_comment()`. [636](https://github.com/JanMarvin/openxlsx2/pull/636)
 
+* Improve support for inputs with `labels` attribute. If e.g. a `factor` label is numeric, we now try to write the label as number. This should impact the way other partially labeled variables are written. [639](https://github.com/JanMarvin/openxlsx2/pull/639)
+
 ## Fixes
 
 * On load `app.xml` is now assigned to `wb$app`. Previously it was loaded but not assigned. [629](https://github.com/JanMarvin/openxlsx2/pull/629)

R/helperFunctions.R

@@ -1122,3 +1122,18 @@ write_workbook.xml.rels <- function(x, rm_sheet = NULL) {
   if (is.null(wxr[["TargetMode"]])) wxr$TargetMode <- ""
   df_to_xml("Relationship", df_col = wxr[c("Id", "Type", "Target", "TargetMode")])
 }
+
+#' convert objects with attribute labels into strings
+#' @param x an object to convert
+#' @keywords internal
+#' @noRd
+to_string <- function(x) {
+  lbls <- attr(x, "labels")
+  chr <- as.character(x)
+  if (!is.null(lbls)) {
+    lbls <- lbls[lbls %in% x]
+    sel_l <- match(lbls, x)
+    if (length(sel_l)) chr[sel_l] <- names(lbls)
+  }
+  chr
+}

R/write.R

@@ -224,8 +224,8 @@ write_data2 <- function(
   if (any(dc == openxlsx2_celltype[["factor"]])) {
     is_factor <- dc == openxlsx2_celltype[["factor"]]
     fcts <- names(dc[is_factor])
-    data[fcts] <- lapply(data[fcts], as.character)
-    dc <- openxlsx2_type(data)
+    data[fcts] <- lapply(data[fcts], to_string)
+    # dc <- openxlsx2_type(data)
   }
 
   hconvert_date1904 <- grepl('date1904="1"|date1904="true"',

src/helper_functions.cpp

@@ -84,7 +84,7 @@ SEXP openxlsx2_type(SEXP x) {
       type[i] = 8;
     } else if (Rf_inherits(z, "comma")) {
       type[i] = 9;
-    } else if (Rf_inherits(z, "factor")) {
+    } else if (Rf_inherits(z, "factor") || !Rf_isNull(Rf_getAttrib(z, Rf_install("labels")))) {
       type[i] = 12;
     } else if (Rf_inherits(z, "hms")) {
       type[i] = 15;
@@ -363,6 +363,9 @@ void wide_to_long(
 
       auto pos = (j * m) + i;
 
+      // factors can be numeric or string or both
+      if (vtyp == factor) string_nums = true;
+
       // create struct
       celltyp cell;
       switch(vtyp)
@@ -382,7 +385,9 @@ void wide_to_long(
         cell.v   = vals;
         cell.c_t = "b";
         break;
+      case factor:
       case character:
+
         // test if string can be written as number
         if (string_nums && is_double(vals)) {
           cell.v   = vals;

tests/testthat/test-write.R

@@ -537,3 +537,34 @@ test_that("write tibble class", {
   expect_equal(tbl, read_xlsx(tmp), ignore_attr = TRUE)
 
 })
+
+
+test_that("writing labeled variables works", {
+
+  x <- c(1, 2, 1, -99, -97)
+  attr(x, "labels") <- c("N/A" = -97, "NaN" = -98, "NA" = -99)
+
+  exp <- c("1", "2", "1", "NA", "N/A")
+  got <- to_string(x)
+
+  wb <- wb_workbook()$add_worksheet()$add_data(x = x)
+
+  exp <- c("1", "2", "1",
+           "<is><t>x</t></is>", "<is><t>NA</t></is>", "<is><t>N/A</t></is>")
+  cc <- wb$worksheets[[1]]$sheet_data$cc[c("v", "is")]
+  cc[cc$v == "", "v"] <- NA
+  cc[cc$is == "", "is"] <- NA
+  got <- unlist(cc[!is.na(cc)])
+  expect_equal(exp, got)
+
+  x <- factor(x = c("M", "F"), levels = c("M", "F"), labels = c(1L, 2L))
+  exp <- c("1", "2")
+  got <- to_string(x)
+  expect_equal(exp, got)
+
+  wb <- wb_workbook()$add_worksheet()$add_data(x = x)
+  exp <- c(1, 2)
+  got <- wb_to_df(wb, colNames = FALSE)$A
+  expect_equal(exp, got)
+
+})