fct_relevel shim (#12)

add `fct_relevel` shim. closes #11 


--------------------------------------------------------------------------------

Pre-review Checklist (if item does not apply, mark is as complete)
- [ ] **All** GitHub Action workflows pass with a ✅
- [ ] PR branch has pulled the most recent updates from master branch:
`usethis::pr_merge_main()`
- [ ] If a bug was fixed, a unit test was added.
- [ ] If a standalone script was updated, a comment is added to the
script header (changelog) AND the `last-updated` field has been updated.
- [ ] Code coverage is suitable for any new functions/features
(generally, 100% coverage for new code): `devtools::test_coverage()`
- [ ] Request a reviewer

Reviewer Checklist (if item does not apply, mark is as complete)

- [ ] If a bug was fixed, a unit test was added.
- [ ] If a standalone script was updated, a comment is added to the
script header (changelog) AND the `last-updated` field has been updated.
- [ ] Run `pkgdown::build_site()`. Check the R console for errors, and
review the rendered website.
- [ ] Code coverage is suitable for any new functions/features:
`devtools::test_coverage()`

When the branch is ready to be merged:
- [ ] **All** GitHub Action workflows pass with a ✅
- [ ] Approve Pull Request
- [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge".
- [ ] Create an issue in any repositories using {standalone} to update
the standalone scripts.

---------

Co-authored-by: Daniel Sjoberg <[email protected]>

R/standalone-forcats.R

@@ -11,6 +11,8 @@
 # of programming.
 #
 # ## Changelog
+# 2025-02-24
+#   - `add fct_relevel()` function.
 #
 # nocov start
 # styler: off
@@ -65,6 +67,21 @@ fct_na_value_to_level <- function(f, level = NA) {
 }
 
 
+fct_relevel <- function(f, ..., after = 0L) {
+  old_levels <- levels(f)
+  # Handle re-leveling function or specified levels
+  first_levels <- if (rlang::dots_n(...) == 1L && (is.function(..1) || rlang::is_formula(..1))) {
+    fun <- rlang::as_function(..1)
+    fun(old_levels)
+  } else {
+    rlang::chr(...)
+  }
+
+  # Reorder levels
+  new_levels <- append(setdiff(old_levels, first_levels), first_levels, after = after)
+  new_factor <- factor(f, levels = new_levels)
+  return(new_factor)
+}
 
 # nocov end
 # styler: on

standalone.Rproj

@@ -1,4 +1,5 @@
 Version: 1.0
+ProjectId: 93321749-01f4-4a80-883a-9039bf424b80
 
 RestoreWorkspace: No
 SaveWorkspace: No

tests/testthat/test-standalone-forcats.R

@@ -41,3 +41,15 @@ test_that("fct_na_value_to_level() works", {
   forcats::fct_na_value_to_level(f2, "(Missing)")
   fct_na_value_to_level(f2, "(Missing)")
 })
+
+test_that("fct_relevel() works", {
+  f <- factor(c("b", "b", "a", "c", "c", "c"))
+  expect_equal(forcats::fct_relevel(fct_relevel(f, "b", "a")), fct_relevel(f, "b", "a"))
+  expect_equal(forcats::fct_relevel(f, "a", after = Inf), fct_relevel(f, "a", after = Inf))
+  expect_equal(forcats::fct_relevel(f, rev), fct_relevel(f, rev))
+  expect_equal(forcats::fct_relevel(f, ~rev(.x)), fct_relevel(f, ~rev(.x)))
+
+  # test for unobserved levels
+  f_new <- fct_relevel(f, "b", "a", "d")  # "d" is unobserved
+  expect_equal(levels(f_new), c("b", "a", "d", "c"))  # "d" should be added as a level, even though not observed
+})