diff --git a/NEWS.md b/NEWS.md index 5d459ca22..d0993ba4a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -11,6 +11,7 @@ * Create date is not reset to the present time in each call to `wb_set_properties()`. [1176](https://github.com/JanMarvin/openxlsx2/pull/1176) * Improve handling of file headers and footers for a case where `wb_load()` would previously fail. [1186](https://github.com/JanMarvin/openxlsx2/pull/1186) +* Partial labels were written only over the first element and only if assigned in an ordered fashion. [1189](https://github.com/JanMarvin/openxlsx2/pull/1189) ## Breaking changes diff --git a/R/helper-functions.R b/R/helper-functions.R index 464d8e6de..4bb2aa7dc 100644 --- a/R/helper-functions.R +++ b/R/helper-functions.R @@ -597,11 +597,11 @@ write_workbook.xml.rels <- function(x, rm_sheet = NULL) { #' @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 <- as.character(x) + if (!is.null(lbls) && !is.null(names(lbls))) { + lbls <- lbls[match(x, lbls)] + sel_l <- which(!is.na(lbls)) + if (length(sel_l)) chr[sel_l] <- names(lbls[!is.na(lbls)]) } chr } diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R index 6e670537a..f2bb7873e 100644 --- a/tests/testthat/test-write.R +++ b/tests/testthat/test-write.R @@ -914,6 +914,45 @@ test_that("writing labeled variables works", { }) +test_that("partial labels work", { + vec <- sample(c(0, 1, 2), size = 10, replace = TRUE) + + df <- data.frame( + var1 = vec, + var2 = vec, + var3 = vec, + var4 = vec, + var5 = vec, + var6 = vec, + var7 = ifelse(vec == 0, "No", ifelse(vec == 1, "Yes", "Maybe")) + ) + + attr(df$var1, "labels") <- c(No = 0, Yes = 1, Maybe = 2) # ordered labels + attr(df$var2, "labels") <- c(Yes = 1, Maybe = 2, No = 0) # unordered labels + attr(df$var3, "labels") <- c(Yes = 1, Maybe = 2) # partial labels + attr(df$var4, "labels") <- c(No = 0, Maybe = 2) # partial labels + attr(df$var5, "labels") <- c(Undecided = -1) # unmatched label + + df$var6 <- factor(df$var6, levels = c(1, 0, 2), label = c("Yes", "No", "Maybe")) + + + got <- write_xlsx(x = df)$to_df() + expect_equal(got$var1, got$var7) + expect_equal(got$var2, got$var7) + expect_equal(which(got$var3 != "0"), which(got$var7 != "No")) + expect_equal(which(got$var3 == "0"), which(got$var7 == "No")) + + expect_equal(which(got$var4 != "1"), which(got$var7 != "Yes")) + expect_equal(which(got$var4 == "1"), which(got$var7 == "Yes")) + + expect_equal(which(got$var5 == "0"), which(got$var7 == "No")) + expect_equal(which(got$var5 == "1"), which(got$var7 == "Yes")) + expect_equal(which(got$var5 == "2"), which(got$var7 == "Maybe")) + + expect_equal(got$var6, got$var7) + +}) + test_that("writing in specific encoding works", { skip_on_cran()