Merge branch 'devel'

R/effects.R

@@ -486,7 +486,7 @@ effect_metrics_one_grouped <- function(data, col, cross, negative = FALSE, metho
           "Adjusted R squared", "Degrees of freedom", "Residuals' degrees of freedom",
           "F", "p", "stars"
         )
-      ), relevel = TRUE) |>
+      ), na.missing = TRUE) |>
       stats::na.omit() |>
       dplyr::arrange(.data$Statistic)
 

R/labels.R

@@ -336,10 +336,10 @@ labs_clear <- function(data, cols, labels = NULL) {
 #'               If the column is not found in the codebook, the first column is used.
 #' @param col_to The tidyselect column with target values, defaults to value_label.
 #'               If the column is not found in the codebook, the second column is used
-#' @param relevel By default, the column is converted to a factor with levels found in the codebook.
-#'                Other values will be set to NA. Set relevel to FALSE to keep other values.
+#' @param na.missing By default, the column is converted to a factor with levels combined from the codebook and the data.
+#'                Set na.missing to TRUE to set all levels not found in the codes to NA.
 #' @return Tibble with new labels.
-labs_replace <- function(data, col, codes, col_from="value_name", col_to="value_label", relevel = TRUE) {
+labs_replace <- function(data, col, codes, col_from="value_name", col_to="value_label", na.missing = FALSE) {
 
   # Column without quotes
   # TODO: could we just use "{{ col }}" with quotes in mutate below?
@@ -374,26 +374,36 @@ labs_replace <- function(data, col, codes, col_from="value_name", col_to="value_
   codes <- dplyr::rename(codes,.to = !!col_to)
 
   # Store levels
-  levels_before <- data |>
-    dplyr::select(!! col) |>
-    dplyr::pull(1) |>
-    as.character() |>
-    unique()
+  before <- data |>
+    dplyr::distinct(!!col) |>
+    dplyr::arrange(!!col) |>
+    dplyr::mutate(!!col := as.character(!! col)) |>
+    dplyr::rename(.from = !!col)
+
 
   codes <- codes %>%
-    dplyr::filter(as.character(.data$.from) %in% levels_before) |>
+    dplyr::filter(as.character(.data$.from) %in% before$.from) |>
     dplyr::distinct(dplyr::across(tidyselect::all_of(c(".from", ".to")))) %>%
     stats::na.omit()
 
+
   if (nrow(codes) > 0) {
+
+    # If any values were missing in the codes, add them
+    # and order as before.
+    if  (!na.missing && !all((before$.from %in% codes$.from))) {
+      codes <- before |>
+        dplyr::left_join(codes, by=".from") |>
+        dplyr::mutate(.to = dplyr::coalesce(.data$.to, .data$.from))
+    }
+
     data <- data %>%
       dplyr::mutate(.from = as.character(!!col)) %>%
       dplyr::left_join(codes, by = ".from") %>%
-      dplyr::mutate(!!col := dplyr::coalesce(.data$.to, .data$.from))
+      dplyr::mutate(!!col := .data$.to)
 
-    if (relevel) {
-      data <- dplyr::mutate(data, !!col := factor(!!col, levels=codes$.to))
-    }
+
+    data <- dplyr::mutate(data, !!col := factor(!!col, levels=codes$.to))
     data <- dplyr::select(data, -tidyselect::all_of(c(".from", ".to")))
   }
 

R/plots.R

@@ -1507,13 +1507,13 @@ plot_metrics_items_cor <- function(data, cols, cross, title = TRUE, labels = TRU
   } else if ((scale > 0) || (scale < 0)) {
     pl <- pl +
       ggplot2::scale_fill_manual(
-        values = vlkr_colors_sequential(length(levels(data$value))),
+        values = vlkr_colors_sequential(length(levels(as.factor(data$value)))),
         guide = ggplot2::guide_legend(reverse = TRUE)
       )
   } else {
     pl <- pl +
       ggplot2::scale_fill_manual(
-        values = vlkr_colors_discrete(length(levels(data$value))),
+        values = vlkr_colors_discrete(length(levels(as.factor(data$value)))),
         guide = ggplot2::guide_legend(reverse = TRUE)
       )
   }

tests/testthat/_snaps/labels.md

@@ -91,6 +91,21 @@
       [4] "I only use new offers when I have no other choice"
       [5] "[no answer]"                                      
 
+# Item values are kept even if they are not in the codebook
+
+    Code
+      dplyr::arrange(volker:::labs_replace(dplyr::mutate(dplyr::distinct(data, from = use_private),
+      to = from), to, codes), to)
+    Output
+      # A tibble: 5 x 2
+         from to          
+        <dbl> <fct>       
+      1     1 never       
+      2     2 2           
+      3     3 3           
+      4     4 4           
+      5     5 almost daily
+
 # A common prefix is removed from labels
 
     Code

tests/testthat/test-labels.R

@@ -55,19 +55,35 @@ test_that("Store, clear and restore the codebook", {
     expect_snapshot(cran= TRUE)
 })
 
-# Replace item labels
-test_that("Item labels are replaced and keep their order", {
+# Replace item values
+test_that("Item values are replaced and keep their order", {
 
   data |>
     dplyr::select(adopter) |>
     # TODO: Even if the column was converted to character beforehand
     #  dplyr::mutate(adopter = as.character(adopter)) |>
-    volker:::labs_replace(adopter, volker::codebook(data)) |>
+    volker:::labs_replace(adopter, volker::codebook(data, adopter)) |>
     dplyr::pull(adopter) |>
     levels() |>
     expect_snapshot(cran= TRUE)
 })
 
+
+# Replace item values
+test_that("Item values are kept even if they are not in the codebook", {
+
+  codes <- data |>
+    codebook(use_private) |>
+    filter(value_name %in% c("1","5"))
+
+  data |>
+    dplyr::distinct(from = use_private) |>
+    dplyr::mutate(to = from) |>
+    volker:::labs_replace(to, codes) |>
+    dplyr::arrange(to) |>
+    expect_snapshot(cran= TRUE)
+})
+
 # Get prefix from labels
 test_that("A common prefix is removed from labels", {