NA in levels vs NA in values

DESCRIPTION

@@ -21,16 +21,16 @@ Imports:
     lifecycle,
     magrittr,
     rlang (>= 1.0.0),
-    tibble,
-    withr
+    tibble
 Suggests: 
     covr,
     dplyr,
     ggplot2,
     knitr,
     readr,
     rmarkdown,
-    testthat (>= 3.0.0)
+    testthat (>= 3.0.0),
+    withr
 VignetteBuilder: 
     knitr
 Config/Needs/website: tidyverse/tidytemplate

NAMESPACE

@@ -24,6 +24,8 @@ export(fct_lump_min)
 export(fct_lump_n)
 export(fct_lump_prop)
 export(fct_match)
+export(fct_na_level_to_value)
+export(fct_na_value_to_level)
 export(fct_other)
 export(fct_recode)
 export(fct_relabel)

NEWS.md

@@ -1,5 +1,14 @@
 # forcats (development version)
 
+* `fct_explicit_na()` is deprecated in favour of `fct_na_value_to_level()`.
+
+* New `fct_na_value_to_level()` and `fct_na_level_to_value()` to convert 
+  NA values to NA levels and vice versa (#337).
+
+* `fct_collapse()` can now use `other_level = NA` (#291).
+
+* `fct_count()` works with factors that contain `NA`s in levels.
+
 * `fct_lump_prop()` and friends now work correctly if you supply weights
   and have empty levels (#292).
 

R/collapse.R

@@ -31,21 +31,15 @@ fct_collapse <- function(.f, ..., other_level = NULL, group_other = "DEPRECATED"
     }
   }
 
-  new <- rlang::list2(...)
-  levs <- as.list(unlist(new, use.names = FALSE))
+  dots <- rlang::list2(...)
+
+  old <- unlist(dots, use.names = FALSE) %||% character()
+  new <- rep(names(dots), lengths(dots))
+  out <- lvls_revalue(f, lvls_rename(f, set_names(old, new)))
 
   if (!is.null(other_level)) {
-    levels <- levels(f)
-    new[[other_level]] <- levels[!levels %in% levs]
-    levs <- c(levs, new[[other_level]])
+    out <- lvls_other(out, levels(out) %in% new, other_level)
   }
 
-  names(levs) <- names(new)[rep(seq_along(new), vapply(new, length, integer(1)))]
-  out <- fct_recode(.f, !!!levs)
-
-  if (any(levels(out) == other_level)) {
-    fct_relevel(out, other_level, after = Inf)
-  } else {
-    out
-  }
+  out
 }

R/count.R

@@ -13,12 +13,14 @@
 #' fct_count(f, sort = TRUE)
 #' fct_count(f, sort = TRUE, prop = TRUE)
 fct_count <- function(f, sort = FALSE, prop = FALSE) {
-  f2 <- check_factor(f)
+  f <- check_factor(f)
   n_na <- sum(is.na(f))
 
+  n <- c(tabulate(f, nlevels(f)), if (n_na > 0) n_na)
+
   df <- tibble::tibble(
-    f = fct_inorder(c(levels(f2), if (n_na > 0) NA)),
-    n = c(tabulate(f2, nlevels(f)), if (n_na > 0) n_na)
+    f = fct_unique(f),
+    n = n
   )
 
   if (sort) {

R/explicit_na.R

@@ -1,21 +1,40 @@
 #' Make missing values explicit
 #'
+#' @description
+#' `r lifecycle::badge("deprecated")`
+#'
+#' This function is deprecated because the terminology is confusing;
+#' please use [fct_na_value_to_level()] instead.
+#'
 #' This gives missing values an explicit factor level, ensuring that they
 #' appear in summaries and on plots.
 #'
 #' @param f A factor (or character vector).
 #' @param na_level Level to use for missing values: this is what `NA`s will be
 #'   changed to.
 #' @export
+#' @keywords internal
 #' @examples
 #' f1 <- factor(c("a", "a", NA, NA, "a", "b", NA, "c", "a", "c", "b"))
 #' fct_count(f1)
-#' table(is.na(f1))
+#' table(f1)
+#' sum(is.na(f1))
 #'
+#' # previously
 #' f2 <- fct_explicit_na(f1)
+#' # now
+#' f2 <- fct_na_value_to_level(f1)
+#'
 #' fct_count(f2)
-#' table(is.na(f2))
+#' table(f2)
+#' sum(is.na(f2))
 fct_explicit_na <- function(f, na_level = "(Missing)") {
+  lifecycle::deprecate_warn(
+    when = "1.0.0",
+    what = "fct_explicit_na()",
+    with = "fct_na_value_to_level()"
+  )
+
   f <- check_factor(f)
 
   is_missing <- is.na(f)

R/lump.R

@@ -95,14 +95,7 @@ fct_lump_min <- function(f, min, w = NULL, other_level = "Other") {
     cli::cli_abort("{.arg min} must be a positive number")
   }
 
-  new_levels <- ifelse(level_w >= min, levels(f), other_level)
-
-  if (other_level %in% new_levels) {
-    f <- lvls_revalue(f, new_levels)
-    fct_relevel(f, other_level, after = Inf)
-  } else {
-    f
-  }
+  lvls_other(f, level_w >= min, other_level)
 }
 
 #' @export
@@ -123,20 +116,12 @@ fct_lump_prop <- function(f, prop, w = NULL, other_level = "Other") {
   }
 
   if (prop < 0) {
-    new_levels <- ifelse(prop_n <= -prop, levels(f), other_level)
-  } else {
-    new_levels <- ifelse(prop_n > prop, levels(f), other_level)
-  }
-
-  if (other_level %in% new_levels) {
-    f <- lvls_revalue(f, new_levels)
-    fct_relevel(f, other_level, after = Inf)
+    lvls_other(f, prop_n <= -prop, other_level)
   } else {
-    f
+    lvls_other(f, prop_n > prop, other_level)
   }
 }
 
-
 #' @export
 #' @rdname fct_lump
 fct_lump_n <- function(f, n, w = NULL, other_level = "Other",
@@ -156,14 +141,7 @@ fct_lump_n <- function(f, n, w = NULL, other_level = "Other",
     rank <- rank(-level_w, ties.method = ties.method)
   }
 
-  new_levels <- ifelse(rank <= n, levels(f), other_level)
-
-  if (other_level %in% new_levels) {
-    f <- lvls_revalue(f, new_levels)
-    fct_relevel(f, other_level, after = Inf)
-  } else {
-    f
-  }
+  lvls_other(f, rank <= n, other_level)
 }
 
 #' @export
@@ -172,16 +150,12 @@ fct_lump_lowfreq <- function(f, w = NULL, other_level = "Other") {
   f <- check_factor(f)
   level_w <- compute_weights(f, w)
 
-  new_levels <- ifelse(!in_smallest(level_w), levels(f), other_level)
-
-  if (other_level %in% new_levels) {
-    f <- lvls_revalue(f, new_levels)
-    fct_relevel(f, other_level, after = Inf)
-  } else {
-    f
-  }
+  lvls_other(f, !in_smallest(level_w), other_level)
 }
 
+
+# helpers -----------------------------------------------------------------
+
 compute_weights <- function(f, w = NULL, call = caller_env()) {
   w <- check_weights(w, length(f), call = call)
 

R/na.R

@@ -0,0 +1,72 @@
+#' Convert between `NA` values and `NA` levels
+#'
+#' @description
+#' There are two ways to represent missing values in factors: in the values
+#' and in the levels. `NA`s in the values are most useful for data analysis
+#' (since [is.na()] returns what you expect), but because the `NA` is not
+#' explicitly recorded in the levels, there's no way to control its position
+#' (it's almost always displayed last or not at all). Putting the `NA`s in the levels allows
+#' you to control its display, at the cost of losing accurate `is.na()`
+#' reporting.
+#'
+#' (It is possible to have a factor with missing values in both the values
+#' and the levels but it requires some explicit gymnastics and we don't
+#' recommend it.)
+#'
+#' @param f A factor (or character vector).
+#' @param level Optionally, instead of converting the `NA` values to an
+#'   `NA` level, convert it to a level with this value.
+#' @export
+#' @examples
+#' # Most factors store NAs in the values:
+#' f1 <- fct(c("a", "b", NA, "c", "b", NA))
+#' levels(f1)
+#' as.integer(f1)
+#' is.na(f1)
+#'
+#' # But it's also possible to store them in the levels
+#' f2 <- fct_na_value_to_level(f1)
+#' levels(f2)
+#' as.integer(f2)
+#' is.na(f2)
+#'
+#' # If needed, you can convert back to NAs in the values:
+#' f3 <- fct_na_level_to_value(f2)
+#' levels(f3)
+#' as.integer(f3)
+#' is.na(f3)
+fct_na_value_to_level <- function(f, level = NA) {
+  if (!identical(level, NA) && !is_string(level)) {
+    cli::cli_abort(
+      "{.arg level} must be a string or {.code NA}, not {.obj_type_friendly {level}}."
+    )
+  }
+  f <- check_factor(f)
+
+  f <- fct_expand(f, NA)
+  new_levels <- levels(f)
+  new_levels[is.na(new_levels)] <- level
+
+  lvls_revalue(f, new_levels)
+}
+
+#' @export
+#' @rdname fct_na_value_to_level
+#' @param extra_levels Optionally, a character vector giving additional levels
+#'   that should also be converted to `NA` values.
+fct_na_level_to_value <- function(f, extra_levels = NULL) {
+  f <- check_factor(f)
+  if (!is.null(extra_levels) && !is.character(extra_levels)) {
+    cli::cli_abort(
+      "{.arg extra_levels} must be a string or {.code NULL}, not {.obj_type_friendly {extra_levels}}."
+    )
+  }
+
+  new_levels <- setdiff(levels(f), union(NA, extra_levels))
+  idx <- match(levels(f), new_levels)
+
+  out <- idx[as.integer(f)]
+  attributes(out) <- attributes(f)
+  attr(out, "levels") <- new_levels
+  out
+}

R/other.R

@@ -18,17 +18,22 @@ fct_other <- function(f, keep, drop, other_level = "Other") {
   f <- check_factor(f)
   check_exclusive(keep, drop)
 
-  levels <- levels(f)
   if (!missing(keep)) {
-    levels[!levels %in% keep] <- other_level
+    lvls_other(f, levels(f) %in% keep, other_level)
   } else {
-    levels[levels %in% drop] <- other_level
+    lvls_other(f, !levels(f) %in% drop, other_level)
   }
+}
 
-  if (!other_level %in% levels) {
-    return(f)
+# Replace specified levels (if any), with other.
+# @param keep A logical vector the same length as `levels(f)`
+lvls_other <- function(f, keep, other_level = "Other") {
+  if (all(keep)) {
+    f
+  } else {
+    new_levels <- ifelse(keep, levels(f), other_level)
+    f <- lvls_revalue(f, new_levels)
+    fct_relevel(f, other_level, after = Inf)
   }
-
-  f <- lvls_revalue(f, levels)
-  fct_relevel(f, other_level, after = Inf)
 }
+

R/recode.R

@@ -35,6 +35,10 @@ fct_recode <- function(.f, ...) {
     new_levels <- new_levels[!nulls]
   }
 
+  lvls_revalue(f, lvls_rename(f, new_levels))
+}
+
+lvls_rename <- function(f, new_levels) {
   # Match old levels with new levels
   old_levels <- levels(f)
   idx <- match(new_levels, old_levels)
@@ -49,8 +53,7 @@ fct_recode <- function(.f, ...) {
   }
 
   old_levels[idx] <- names(new_levels)
-
-  lvls_revalue(f, old_levels)
+  old_levels
 }
 
 check_recode_levels <- function(..., call = caller_env()) {

_pkgdown.yml

@@ -46,8 +46,8 @@ reference:
       Leave existing data as is, but add or remove levels.
     contents:
     - fct_expand
-    - fct_explicit_na
     - fct_drop
+    - fct_na_value_to_level
     - fct_unify
 
   - title: Combine multiple factors