From a54cf4b9e5ed23d5978f939e293ac45cc8cb6ade Mon Sep 17 00:00:00 2001 From: jmbarbone Date: Tue, 29 Mar 2022 23:06:13 -0400 Subject: [PATCH 01/25] start vignettes --- DESCRIPTION | 4 +++- vignettes/.gitignore | 2 ++ 2 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 vignettes/.gitignore diff --git a/DESCRIPTION b/DESCRIPTION index 53d527b3..9f366862 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,9 +41,11 @@ Suggests: testthat (>= 3.0.0), tibble (>= 3.0.4), waldo (>= 0.2.5), - withr (>= 2.3.0) + withr (>= 2.3.0), + rmarkdown RoxygenNote: 7.1.2 Roxygen: list(markdown = TRUE) Config/testthat/edition: 3 Config/testthat/parallel: true Language: en-US +VignetteBuilder: knitr diff --git a/vignettes/.gitignore b/vignettes/.gitignore new file mode 100644 index 00000000..097b2416 --- /dev/null +++ b/vignettes/.gitignore @@ -0,0 +1,2 @@ +*.html +*.R From 6f6050fd46968c5c46b55c2a999d914560f2b71e Mon Sep 17 00:00:00 2001 From: jmbarbone Date: Tue, 29 Mar 2022 23:06:25 -0400 Subject: [PATCH 02/25] start vignette on facts --- vignettes/facts.Rmd | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 vignettes/facts.Rmd diff --git a/vignettes/facts.Rmd b/vignettes/facts.Rmd new file mode 100644 index 00000000..0d706ccc --- /dev/null +++ b/vignettes/facts.Rmd @@ -0,0 +1,42 @@ +--- +title: "Working with `facts`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Working with `facts`} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) + +bench_mark <- function(x) { + b <- bench::mark(fact(x), factor(x), forcats::as_factor(x), iterations = 50, check = FALSE) + print(ggplot2::autoplot(b) + ggplot2::labs(title = class(x))) + b +} +``` + +```{r setup} +library(mark) +``` + +`fact`s are a special class much like `factors` but with some performance improvements. + +```{r} +x <- apply(matrix(sample(letters, 1e5, TRUE), ncol = 4), 1, collapse0) +bench_mark(x) + +x <- round(runif(1e5), 2) +bench_mark(x) + +x <- order(x) +bench_mark(x) + +x <- x > 1e5 / 2 +x[sample(x, 1e3)] <- NA +bench_mark(x) +``` From 2133dcef06a233052c368041e398422d128a36ef Mon Sep 17 00:00:00 2001 From: jmbarbone Date: Thu, 31 Mar 2022 22:59:40 -0400 Subject: [PATCH 03/25] start table with differences --- vignettes/facts.Rmd | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/vignettes/facts.Rmd b/vignettes/facts.Rmd index 0d706ccc..177595fc 100644 --- a/vignettes/facts.Rmd +++ b/vignettes/facts.Rmd @@ -26,6 +26,13 @@ library(mark) `fact`s are a special class much like `factors` but with some performance improvements. +| Case | `factor()` | `fact()` | +| ------- | ---------- | -------- | +| Level sorting | When not set, sorts | Sorts numbers, preset sorting for logical, no sorting for character | +| `NA` | Default levels don't include `NA` | When `NA` is present, is added as the last level | +| S3 methods | None | S3 methods can extend functionality | +| Attributes | `levels`, `class`| `levels`, `a`, `uniques`, `na`, `class` | + ```{r} x <- apply(matrix(sample(letters, 1e5, TRUE), ncol = 4), 1, collapse0) bench_mark(x) From b6d96ef45f725a1bad571991557283770c90fdfc Mon Sep 17 00:00:00 2001 From: jmbarbone Date: Thu, 31 Mar 2022 23:03:36 -0400 Subject: [PATCH 04/25] mention s3 methods --- vignettes/facts.Rmd | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/vignettes/facts.Rmd b/vignettes/facts.Rmd index 177595fc..5133eb7f 100644 --- a/vignettes/facts.Rmd +++ b/vignettes/facts.Rmd @@ -47,3 +47,11 @@ x <- x > 1e5 / 2 x[sample(x, 1e3)] <- NA bench_mark(x) ``` + +`fact()` takes an S3 approach for factors which allows data to take different sorting and matching processes. +This allows `fact()` to be most efficient with its labeling and transformations. +This differs from `factor()` which uses the same process, and always sorts labels in ascending order. + +```{r} +utils::methods("fact") +``` From e7aeba65038af73af3414203e6bdab357c20b667 Mon Sep 17 00:00:00 2001 From: jmbarbone Date: Thu, 31 Mar 2022 23:03:48 -0400 Subject: [PATCH 05/25] show some examples --- vignettes/facts.Rmd | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/vignettes/facts.Rmd b/vignettes/facts.Rmd index 5133eb7f..401b174a 100644 --- a/vignettes/facts.Rmd +++ b/vignettes/facts.Rmd @@ -55,3 +55,42 @@ This differs from `factor()` which uses the same process, and always sorts label ```{r} utils::methods("fact") ``` + +`fact()` currently doesn't have any further arguments than `x`, the object passed to it. + +```{r} +x <- 4:1 +factor(x) +fact(x) +``` + +```{r} +x <- c("j", "m", "b") +factor(x) +fact(x) +``` + +```{r} +x <- c(1, 3, 2, 0) +factor(x) +fact(x) +``` + +```{r} +x <- c(TRUE, NA, FALSE) +factor(x) +fact(x) +``` + +The last example also highlights `fact()`'s handling of `NA`s. +For `fact()`, `NA` values are always stored as the last `level`. + +```{r} +x <- as.Date("2022-03-29") - 0:2 + +x1 <- factor(x) +x2 <- fact(x) + +bench::mark(as.Date(x1), foo(x2)) +``` + From 7e22f16c27efac4f1785e535223a2b1474dcb27e Mon Sep 17 00:00:00 2001 From: jmbarbone Date: Thu, 7 Apr 2022 21:45:03 -0400 Subject: [PATCH 06/25] formatting and more notes --- vignettes/facts.Rmd | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/vignettes/facts.Rmd b/vignettes/facts.Rmd index 401b174a..97f3d108 100644 --- a/vignettes/facts.Rmd +++ b/vignettes/facts.Rmd @@ -31,13 +31,14 @@ library(mark) | Level sorting | When not set, sorts | Sorts numbers, preset sorting for logical, no sorting for character | | `NA` | Default levels don't include `NA` | When `NA` is present, is added as the last level | | S3 methods | None | S3 methods can extend functionality | -| Attributes | `levels`, `class`| `levels`, `a`, `uniques`, `na`, `class` | +| Parameters | `x = character()`, `levels`, `labels = levels`, `exclude = NA`, `ordered = is.ordered(x)`, `nmax = NA` | `x` | +| Attributes | `levels`, `class`| `levels`, `uniques`, `na`, `class` | -```{r} -x <- apply(matrix(sample(letters, 1e5, TRUE), ncol = 4), 1, collapse0) +```{r, fig.width=6} +x <- apply(matrix(sample(letters, 1e3, TRUE), ncol = 4), 1, collapse0) bench_mark(x) -x <- round(runif(1e5), 2) +x <- round(runif(1e3), 2) bench_mark(x) x <- order(x) @@ -57,6 +58,8 @@ utils::methods("fact") ``` `fact()` currently doesn't have any further arguments than `x`, the object passed to it. +This makes their utility different than `factor()`, the later of which can be helpful when levels are known a prior. +Otherwise, `fact()` is better suited for not knowing levels. ```{r} x <- 4:1 @@ -76,6 +79,10 @@ factor(x) fact(x) ``` +There is a divergence here, where `fact` is meant to understand that boolean operations can have 3 possible outcomes and that it might be best to allow at least `TRUE` and `FALSE` regardless of their presence. +This is also a standout for performance. +`factor()` runs the same routine for all data, so many of the check are a bit useless if you don't intend to rec + ```{r} x <- c(TRUE, NA, FALSE) factor(x) @@ -88,9 +95,8 @@ For `fact()`, `NA` values are always stored as the last `level`. ```{r} x <- as.Date("2022-03-29") - 0:2 -x1 <- factor(x) +fact1 <- factor(x) x2 <- fact(x) -bench::mark(as.Date(x1), foo(x2)) +bench::mark(as.Date(x1), as.Date(x2)) ``` - From 546f64e421c3f0bf6ed3699cf70ea5fd3b3df9d5 Mon Sep 17 00:00:00 2001 From: jmbarbone Date: Sat, 28 May 2022 17:42:29 -0400 Subject: [PATCH 07/25] add namespace checks to vignette --- vignettes/facts.Rmd | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/vignettes/facts.Rmd b/vignettes/facts.Rmd index 97f3d108..b9931853 100644 --- a/vignettes/facts.Rmd +++ b/vignettes/facts.Rmd @@ -14,8 +14,9 @@ knitr::opts_chunk$set( ) bench_mark <- function(x) { + if (!(requireNamespace("bench") & requireNamespace("forcats"))) return(NULL) b <- bench::mark(fact(x), factor(x), forcats::as_factor(x), iterations = 50, check = FALSE) - print(ggplot2::autoplot(b) + ggplot2::labs(title = class(x))) + if (requireNamespace("ggplot2")) print(ggplot2::autoplot(b) + ggplot2::labs(title = class(x))) b } ``` From 4cbbfe538a0ea3cd8015d1dc6724e1a6326f5f10 Mon Sep 17 00:00:00 2001 From: jmbarbone Date: Mon, 20 Jun 2022 21:33:39 -0400 Subject: [PATCH 08/25] resolves #119 --- R/fact.R | 4 +++- tests/testthat/test-fact.R | 7 +++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/R/fact.R b/R/fact.R index 59959339..624c962b 100644 --- a/R/fact.R +++ b/R/fact.R @@ -40,11 +40,13 @@ fact <- function(x) { #' @rdname fact #' @export fact.default <- function(x) { - stop( + warning( "No fact method for class(es) ", collapse0(class(x), sep = ", "), + "\nDefaulting to fact.character()", call. = FALSE ) + fact(as.character(x)) } #' @rdname fact diff --git a/tests/testthat/test-fact.R b/tests/testthat/test-fact.R index 945a26a7..c0e3f8fa 100644 --- a/tests/testthat/test-fact.R +++ b/tests/testthat/test-fact.R @@ -1,3 +1,10 @@ +# fact.default() ---- + +test_that("fact.default() works", { + x <- struct(1, "foo") + expect_warning(res <- fact(x)) + expect_identical(res, fact(as.character(x))) +}) # fact.logical() ---- From 305301c54dce38b2faef7cc20879bde287bd26e9 Mon Sep 17 00:00:00 2001 From: jmbarbone Date: Mon, 20 Jun 2022 21:34:06 -0400 Subject: [PATCH 09/25] add notes on S3 methods --- vignettes/facts.Rmd | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/vignettes/facts.Rmd b/vignettes/facts.Rmd index b9931853..a49546eb 100644 --- a/vignettes/facts.Rmd +++ b/vignettes/facts.Rmd @@ -32,9 +32,20 @@ library(mark) | Level sorting | When not set, sorts | Sorts numbers, preset sorting for logical, no sorting for character | | `NA` | Default levels don't include `NA` | When `NA` is present, is added as the last level | | S3 methods | None | S3 methods can extend functionality | -| Parameters | `x = character()`, `levels`, `labels = levels`, `exclude = NA`, `ordered = is.ordered(x)`, `nmax = NA` | `x` | +| Parameters | `x = character()`, `levels`, `labels = levels`, `exclude = NA`, `ordered = is.ordered(x)`, `nmax = NA` | `x` | | Attributes | `levels`, `class`| `levels`, `uniques`, `na`, `class` | +Notes on S3 methods + +| Class | Notes | +| ----- | ---------- | +| `.default` | Warns and defaults to `character()`. Adding new S3 methods will avoid this warning | +| `.character` | Does not perform any sorting, levels taken as they appear in the data | +| `.numeric`, `.integer`, `.Date`, `POSIXt` | Performs radix sorting, treats `NaN` as `NA` | +| `.factor` | Tries to restore data types before dispatching S3 methods | +| `.fact` | Returns values -- assumes value was created with `fact()` | +| `.haven_labelled` | Designed to mimic `haven::as_factor.haven_labelled()` | + ```{r, fig.width=6} x <- apply(matrix(sample(letters, 1e3, TRUE), ncol = 4), 1, collapse0) bench_mark(x) @@ -81,7 +92,7 @@ fact(x) ``` There is a divergence here, where `fact` is meant to understand that boolean operations can have 3 possible outcomes and that it might be best to allow at least `TRUE` and `FALSE` regardless of their presence. -This is also a standout for performance. +This understanding also speeds up performance and becomes much quicker. `factor()` runs the same routine for all data, so many of the check are a bit useless if you don't intend to rec ```{r} From b4d9f7f8d63d2ffabb34ea8608a72a24c44320c3 Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sun, 16 Oct 2022 23:29:07 -0400 Subject: [PATCH 10/25] [#91] facts as reexports --- R/fact.R | 536 +------------------------------------------------------ 1 file changed, 5 insertions(+), 531 deletions(-) diff --git a/R/fact.R b/R/fact.R index 2dc80e40..946779ed 100644 --- a/R/fact.R +++ b/R/fact.R @@ -1,546 +1,20 @@ # fact -------------------------------------------------------------------- -#' Factor -#' -#' Quickly create a factor -#' -#' @details `fact()` can be about 5 times quicker than `factor()` or -#' `as.factor()` as it doesn't bother sorting the levels for non-numeric data -#' or have other checks or features. It simply converts a vector to a factor -#' with all unique values as levels with `NA`s included. -#' -#' `fact.factor()` will perform several checks on a factor to include `NA` -#' levels and to check if the levels should be reordered to conform with the -#' other methods. The `fact.fact()` method simple returns `x`. -#' -#' @section level orders: -#' -#' The order of the levels may be adjusted to these rules depending on the class -#' of `x`: -#' \describe{ -#' \item{`character`}{The order of appearance} -#' \item{`numeric`/`integer`/`Date`/`POSIXt`}{By the numeric order} -#' \item{`logical`}{As `TRUE`, `FALSE`, then `NA` if present} -#' \item{`factor`}{Numeric if levels can be safely converted, otherwise as -#' they are} -#' } -#' -#' @param x A vector of values -#' @return A vector of equal length of `x` with class `fact` and `factor`. If -#' `x` was `ordered`, that class is added in between. -#' -#' @seealso [as_ordered()] -#' @family factors -#' @export -fact <- function(x) { - UseMethod("fact", x) -} - -#' @rdname fact -#' @export -fact.default <- function(x) { - warning( - "No fact method for class(es) ", - collapse0(class(x), sep = ", "), - "\nDefaulting to fact.character()", - call. = FALSE - ) - fact(as.character(x)) -} - -#' @rdname fact -#' @export -fact.character <- function(x) { - out <- pseudo_id(x) - new_fact(out, .uniques(out)) -} - -#' @rdname fact -#' @export -fact.numeric <- function(x) { - u <- sort.int(unique(x), method = "radix", na.last = TRUE) - - # Don't bother NaN - nas <- is.na(u) - u[nas] <- NA - - if (sum(nas) > 1) { - u <- u[-length(u)] - } - - x[is.nan(x)] <- NA - new_fact(match(x, u), u) -} - -#' @rdname fact -#' @export -fact.integer <- fact.numeric - -#' @rdname fact -#' @export -fact.Date <- fact.numeric - -#' @rdname fact -#' @export -fact.POSIXt <- fact.numeric - -#' @rdname fact -#' @export -fact.logical <- function(x) { - out <- as.integer(x) - w <- which(!x) - out[w] <- out[w] + 2L - nas <- is.na(x) - out[nas] <- 3L - - new_fact( - out, - levels = c(TRUE, FALSE, if (any(nas)) NA), - na = if (any(nas)) 3L else 0L - ) -} - -#' @rdname fact -#' @export -fact.factor <- function(x) { - old_levels <- levels(x) - new_levels <- fact_coerce_levels(old_levels) - # new_levels <- type_convert2(old_levels) - - if (is.logical(new_levels)) { - m <- match(new_levels[x], c(TRUE, FALSE, NA)) - res <- new_fact(m, c(TRUE, FALSE, if (anyNA(new_levels[x])) NA)) - return(res) - } - - if (is.numeric(new_levels) | inherits(x, c("Date", "POSIXt"))) { - ord_levels <- sort(new_levels, na.last = TRUE) - o <- match(old_levels, as.character(ord_levels)) - - levels <- c(ord_levels, if (anyNA(x) && !anyNA(ord_levels)) NA) - - if (identical(o, seq_along(o))) { - res <- new_fact(x, levels, is.ordered(x)) - return(res) - } - - m <- match(order(old_levels), o)[x] - res <- new_fact(m, levels, is.ordered(x)) - return(res) - } - - if (anyNA(x) || anyNA(old_levels)) { - new_levels <- - if (!anyNA(new_levels)) { - c(new_levels, NA) - } else { - na_last(new_levels) - } - } - - m <- match(old_levels, as.character(new_levels))[x] - new_fact(m, new_levels, is.ordered(x)) -} - -#' @rdname fact -#' @export -fact.fact <- function(x) { - x -} - -#' @rdname fact -#' @export -fact.pseudo_id <- function(x) { - u <- .uniques(x) - - # check if numeric and already ordered - if (is.numeric(u)) { - o <- order(u) - if (!identical(o, u)) { - x <- match(u[o], u)[x] - u <- u[o] - } - } - - new_fact(x, levels = u) -} - -#' @rdname fact -#' @export -fact.haven_labelled <- function(x) { - require_namespace("haven") - lvls <- attr(x, "labels") - - if (length(lvls)) { - ux <- unclass(x) - uniques <- sort.int(unique(c(ux, lvls))) - m <- match(ux, uniques) - ml <- match(lvls, uniques) - uniques[ml] <- names(lvls) - res <- new_fact(m, uniques) - } else { - res <- fact(unclass(x)) - } - - attr(res, "label") <- exattr(x, "label") - res -} - -#' @export -print.fact <- function( - x, - max_levels = getOption("mark.fact.max_levels", TRUE), - width = getOption("width"), - ... -) { - # mostly a reformatted base::print.factor() - ord <- is.ordered(x) - if (length(x) == 0L) { - cat(if (ord) "ordered" else "factor", "(0)\n", sep = "") - } else { - print(as.character(x), quote = FALSE, ...) - } - - if (max_levels) { - lev <- encodeString(levels(x), quote = "") - n <- length(lev) - colsep <- if (ord) " < " else " " - T0 <- "Levels: " - if (is.logical(max_levels)) { - max_levels <- { - width <- width - (nchar(T0, "w") + 3L + 1L + 3L) - lenl <- cumsum(nchar(lev, "w") + nchar(colsep, "w")) - - if (n <= 1L || lenl[n] <= width) { - n - } else { - max(1L, which.max(lenl > width) - 1L) - } - } - } - drop <- n > max_levels - cat( - if (drop) paste(format(n), ""), - T0, - paste( - if (drop) { - c(lev[1L:max(1, max_levels - 1)], "...", if (max_levels > 1) lev[n]) - } else { - lev - }, - collapse = colsep - ), - "\n", - sep = "" - ) - - # Be nice to haven_labelled - lab <- exattr(x, "label") - if (!is.null(lab)) { - cat("Label: ", paste(format(lab), ""), "\n", sep = "") - } - } - - invisible(x) -} +fact <- facts::fact # as_ordered -------------------------------------------------------------- -#' Ordered -#' -#' As ordered -#' -#' @details Simple implementation of `ordered`. If `x` is `ordered` it is -#' simply returned. If `x` is a `factor` the `ordered` class is added. -#' Otherwise, `x` is made into a `factor` with [mark::fact()] and then the -#' `ordered` class is added. Unlike just `fact`, `ordered` will replace the `NA` -#' levels with `NA_integer_` to work appropriately with other functions. -#' -#' @inheritParams fact -#' @seealso [fact()] -#' @family factors -#' @export -#' @returns An `ordered` vector -#' @examples -#' x <- c("a", NA, "b") -#' x <- fact(x) -#' str(x) # NA is 3L -#' -#' y <- x -#' class(y) <- c("ordered", class(y)) -#' max(y) -#' max(y, na.rm = TRUE) # returns NA -- bad -#' -#' # as_ordered() removes the NA level -#' x <- as_ordered(x) -#' str(x) -#' max(x, na.rm = TRUE) # returns b -- correct - -as_ordered <- function(x) { - UseMethod("as_ordered", x) -} - -#' @rdname as_ordered -#' @export -as_ordered.default <- function(x) { - res <- fact_na(x, remove = TRUE) - - if (!is.ordered(x)) { - res <- add_class(res, "ordered", 2L) - } - - res -} - +as_ordered <- facts::as_ordered # drop_levels ------------------------------------------------------------- -#' Drop levels -#' -#' Drop unused levels of a factor -#' -#' @param x A `factor` or `data.frame` -#' @param ... Additional arguments passed to methods (not used) -#' @seealso [base::droplevels] -#' @export -#' @family factors -drop_levels <- function(x, ...) { - UseMethod("drop_levels", x) -} - -#' @export -#' @rdname drop_levels -drop_levels.data.frame <- function(x, ...) { - factors <- which(vap_lgl(x, is.factor)) - x[factors] <- lapply(x[factors], drop_levels) - x -} - -#' @export -#' @rdname drop_levels -drop_levels.fact <- function(x, ...) { - if (is.ordered(x)) { - as_ordered(fact_values(x)) - } else { - fact(fact_values(x)) - } -} - -#' @export -#' @rdname drop_levels -drop_levels.factor <- function(x, ...) { - chr <- as.character(x) - lvl <- levels(x) %wi% chr - struct( - match(chr, lvl), - class = c(if (is.fact(x)) "fact", if (is.ordered(x)) "ordered", "factor"), - levels = lvl - ) -} +drop_levels <- facts::drop_levels # fact_na ----------------------------------------------------------------- -#' `fact` with `NA` -#' -#' Included `NA` values into `fact()` -#' -#' @details -#' This re-formats the `x` value so that `NA`s are found immediately within the -#' object rather than accessed through its attributes. -#' -#' @param x A `fact` or object cohered to `fact` -#' @param remove If `TRUE` removes `NA` value from the `fact` `levels` and -#' `uniques` attributes -#' @returns A `fact` vector -#' @family factors -#' @export -fact_na <- function(x, remove = FALSE) { - x <- fact(x) - na <- attr(x, "na") - - if (na == 0L) { - return(x) - } - - if (remove) { - attr(x, "levels") <- attr(x, "levels")[-na] - attr(x, "uniques") <- attr(x, "uniques")[-na] - } - - a <- attributes(x) - x <- unclass(x) - x[x == na] <- NA_integer_ - attributes(x) <- a - attr(x, "na") <- 0L - x -} +fact_na <- facts::fact_na # fact_reverse ------------------------------------------------------------ -#' Fact reverse levels -#' -#' Reverse the levels of a `fact` -#' -#' @param x A `fact` object (or passed to [fact()]) -fact_reverse <- function(x) { - x <- fact(x) - lvls <- flip(attr(x, "uniques")) - seq <- flip(seq_along(lvls)) - na <- attr(x, "na") - - if (na > 0) { - lvls <- c(lvls[-1L], lvls[1L]) - seq <- c(seq[-1L], seq[1L]) - } - - new_fact(seq[x], levels = lvls, ordered = is.ordered(x), na = na) -} - -# other methods ----------------------------------------------------------- - -#' @export -as.integer.fact <- function(x, ...) { - x <- fact_na(x) - nas <- is.na(x) - attributes(x) <- NULL - class(x) <- "integer" - x[nas] <- NA_integer_ - x -} - -#' @export -as.double.fact <- function(x, ...) { - as.double(as.integer(x)) -} - -#' @export -as.character.fact <- function(x, ...) { - as.character(attr(x, "uniques")[x]) -} - -# because unique.factor() remakes factor -# this won't drop levels -#' @export -unique.fact <- function(x, incomparables = FALSE, ...) { - att <- attributes(x) - struct( - unique(unclass(x)), - class = att$class, - levels = att$levels, - uniques = att$uniques, - na = att$na - ) -} - -#' @export -as.Date.fact <- function(x, ...) { - as.Date(attr(x, "uniques"), ...)[x] -} - -#' @export -`[.fact` <- function(x, ...) { - y <- NextMethod("[") - attributes(y) <- attributes(x) - y -} - -# helpers ----------------------------------------------------------------- - -new_fact <- function( - x, - levels, - ordered = FALSE, - na = if (anyNA(levels)) length(levels) else 0L -) { - struct( - as.integer(x), - class = c("fact", if (ordered) "ordered", "factor"), - levels = as.character(levels), - uniques = levels, - na = na - ) -} - -try_numeric <- function(x) { - if (is.numeric(x)) { - return(x) - } - - nas <- is.na(x) - - if (all(nas)) { - return(x) - } - - nums <- wuffle(as.numeric(x[!nas])) - - if (anyNA(nums)) { - return(x) - } - - out <- rep.int(NA_real_, length(x)) - out[!nas] <- nums - out -} - -fact_values <- function(x) { - if (!is.fact(x)) { - stop("x must be a fact object", call. = FALSE) - } - - attr(x, "uniques")[as.integer(x)] -} - -fact_coerce_levels <- function(x) { - nas <- is.na(x) - - if (all(nas) || !anyNA(match(x[!nas], c("TRUE", "FALSE")))) { - return(as.logical(x)) - } - - tz <- getOption("mark.default_tz", "UTC") - wuffle({ - numbers <- as.numeric(x[!nas]) - dates <- as.Date(x[!nas], optional = TRUE) - posix <- as.POSIXct( - x = x[!nas], - tryFormats = try_formats(), - tz = tz, - optional = TRUE - ) - - }) - - n <- length(x) - - if (!anyNA(dates) && all(nchar(x[!nas]) == 10L)) { - x <- rep(NA_Date_, n) - x[!nas] <- dates - } else if (!anyNA(posix)) { - x <- rep(NA_real_, n) - stopifnot(all(!nas)) - x[] <- as.double(posix) - x <- as.POSIXct( - x = x, - origin = "1970-01-01", - tz = tz - ) - } else if (!anyNA(numbers)) { - x <- rep(NA_real_, n) - x[!nas] <- numbers - } - - x -} - -`fact_levels<-` <- function(x, value) { - x <- fact(x) - levels <- levels(x) - value <- c(value, if (!anyNA(value) & (anyNA(x) | anyNA(levels))) NA) - new_fact(match(levels, value)[x], value, is.ordered(x)) -} - -is.fact <- function(x) { - inherits(x, "fact") -} +fact_reverse <- facts:::fact_reverse From 4600877e31de0e8181a5bbeaa1ab1779b34175f1 Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sun, 16 Oct 2022 23:29:23 -0400 Subject: [PATCH 11/25] [#91] use remotes for dev --- DESCRIPTION | 2 ++ 1 file changed, 2 insertions(+) diff --git a/DESCRIPTION b/DESCRIPTION index 48bb0e9a..ec1c55d8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,6 +21,7 @@ LazyData: true Depends: R (>= 3.6) Imports: + facts, magrittr (>= 2.0.1), stats (>= 3.6), tools (>= 3.6), @@ -49,3 +50,4 @@ Config/testthat/edition: 3 Config/testthat/parallel: true Language: en-US VignetteBuilder: knitr +Remotes: github::jmbarbone/facts From 03834d605c694c0a5b77c9269df548221d391182 Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sun, 16 Oct 2022 23:29:37 -0400 Subject: [PATCH 12/25] [#91] redoc --- NAMESPACE | 26 -------------- man/as_ordered.Rd | 53 ---------------------------- man/char2fact.Rd | 6 +--- man/drop_levels.Rd | 36 ------------------- man/fact.Rd | 86 --------------------------------------------- man/fact2char.Rd | 6 +--- man/fact_na.Rd | 33 ----------------- man/fact_reverse.Rd | 14 -------- 8 files changed, 2 insertions(+), 258 deletions(-) delete mode 100644 man/as_ordered.Rd delete mode 100644 man/drop_levels.Rd delete mode 100644 man/fact.Rd delete mode 100644 man/fact_na.Rd delete mode 100644 man/fact_reverse.Rd diff --git a/NAMESPACE b/NAMESPACE index 4bab81c7..633d8ee0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,14 +1,8 @@ # Generated by roxygen2: do not edit by hand -S3method("[",fact) S3method(append0,data.frame) S3method(append0,default) S3method(append0,list) -S3method(as.Date,fact) -S3method(as.character,fact) -S3method(as.double,fact) -S3method(as.integer,fact) -S3method(as_ordered,default) S3method(assign_labels,data.frame) S3method(assign_labels,default) S3method(char2fact,character) @@ -23,20 +17,6 @@ S3method(depth,default) S3method(depth,list) S3method(detail,data.frame) S3method(detail,default) -S3method(drop_levels,data.frame) -S3method(drop_levels,fact) -S3method(drop_levels,factor) -S3method(fact,Date) -S3method(fact,POSIXt) -S3method(fact,character) -S3method(fact,default) -S3method(fact,fact) -S3method(fact,factor) -S3method(fact,haven_labelled) -S3method(fact,integer) -S3method(fact,logical) -S3method(fact,numeric) -S3method(fact,pseudo_id) S3method(flip,data.frame) S3method(flip,default) S3method(flip,matrix) @@ -49,7 +29,6 @@ S3method(is_true,logical) S3method(normalize,data.frame) S3method(normalize,default) S3method(print,diff_time) -S3method(print,fact) S3method(print,has_catch) S3method(print,mark_bib_df) S3method(print,mark_bib_entry) @@ -75,7 +54,6 @@ S3method(to_boolean,character) S3method(to_boolean,factor) S3method(to_boolean,logical) S3method(to_boolean,numeric) -S3method(unique,fact) S3method(write_clipboard,data.frame) S3method(write_clipboard,default) S3method(write_clipboard,list) @@ -101,7 +79,6 @@ export(add_file_timestamp) export(any_match) export(are_identical) export(array_extract) -export(as_ordered) export(assign_labels) export(base_alpha) export(base_n) @@ -128,15 +105,12 @@ export(diff_time_secs) export(diff_time_weeks) export(diff_time_wyears) export(diff_time_years) -export(drop_levels) export(either) export(environments) export(ept) export(eval_named_chunk) export(expand_by) -export(fact) export(fact2char) -export(fact_na) export(fct_expand_seq) export(file_name) export(file_open) diff --git a/man/as_ordered.Rd b/man/as_ordered.Rd deleted file mode 100644 index 217ae215..00000000 --- a/man/as_ordered.Rd +++ /dev/null @@ -1,53 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fact.R -\name{as_ordered} -\alias{as_ordered} -\alias{as_ordered.default} -\title{Ordered} -\usage{ -as_ordered(x) - -\method{as_ordered}{default}(x) -} -\arguments{ -\item{x}{A vector of values} -} -\value{ -An \code{ordered} vector -} -\description{ -As ordered -} -\details{ -Simple implementation of \code{ordered}. If \code{x} is \code{ordered} it is -simply returned. If \code{x} is a \code{factor} the \code{ordered} class is added. -Otherwise, \code{x} is made into a \code{factor} with \code{\link[=fact]{fact()}} and then the -\code{ordered} class is added. Unlike just \code{fact}, \code{ordered} will replace the \code{NA} -levels with \code{NA_integer_} to work appropriately with other functions. -} -\examples{ -x <- c("a", NA, "b") -x <- fact(x) -str(x) # NA is 3L - -y <- x -class(y) <- c("ordered", class(y)) -max(y) -max(y, na.rm = TRUE) # returns NA -- bad - -# as_ordered() removes the NA level -x <- as_ordered(x) -str(x) -max(x, na.rm = TRUE) # returns b -- correct -} -\seealso{ -\code{\link[=fact]{fact()}} - -Other factors: -\code{\link{char2fact}()}, -\code{\link{drop_levels}()}, -\code{\link{fact2char}()}, -\code{\link{fact_na}()}, -\code{\link{fact}()} -} -\concept{factors} diff --git a/man/char2fact.Rd b/man/char2fact.Rd index d354fc32..b1da5780 100644 --- a/man/char2fact.Rd +++ b/man/char2fact.Rd @@ -30,10 +30,6 @@ Converts characters to factors #' @seealso \code{\link[=fact2char]{fact2char()}} Other factors: -\code{\link{as_ordered}()}, -\code{\link{drop_levels}()}, -\code{\link{fact2char}()}, -\code{\link{fact_na}()}, -\code{\link{fact}()} +\code{\link{fact2char}()} } \concept{factors} diff --git a/man/drop_levels.Rd b/man/drop_levels.Rd deleted file mode 100644 index 9cdd88ff..00000000 --- a/man/drop_levels.Rd +++ /dev/null @@ -1,36 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fact.R -\name{drop_levels} -\alias{drop_levels} -\alias{drop_levels.data.frame} -\alias{drop_levels.fact} -\alias{drop_levels.factor} -\title{Drop levels} -\usage{ -drop_levels(x, ...) - -\method{drop_levels}{data.frame}(x, ...) - -\method{drop_levels}{fact}(x, ...) - -\method{drop_levels}{factor}(x, ...) -} -\arguments{ -\item{x}{A \code{factor} or \code{data.frame}} - -\item{...}{Additional arguments passed to methods (not used)} -} -\description{ -Drop unused levels of a factor -} -\seealso{ -\link[base:droplevels]{base::droplevels} - -Other factors: -\code{\link{as_ordered}()}, -\code{\link{char2fact}()}, -\code{\link{fact2char}()}, -\code{\link{fact_na}()}, -\code{\link{fact}()} -} -\concept{factors} diff --git a/man/fact.Rd b/man/fact.Rd deleted file mode 100644 index 241a2370..00000000 --- a/man/fact.Rd +++ /dev/null @@ -1,86 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fact.R -\name{fact} -\alias{fact} -\alias{fact.default} -\alias{fact.character} -\alias{fact.numeric} -\alias{fact.integer} -\alias{fact.Date} -\alias{fact.POSIXt} -\alias{fact.logical} -\alias{fact.factor} -\alias{fact.fact} -\alias{fact.pseudo_id} -\alias{fact.haven_labelled} -\title{Factor} -\usage{ -fact(x) - -\method{fact}{default}(x) - -\method{fact}{character}(x) - -\method{fact}{numeric}(x) - -\method{fact}{integer}(x) - -\method{fact}{Date}(x) - -\method{fact}{POSIXt}(x) - -\method{fact}{logical}(x) - -\method{fact}{factor}(x) - -\method{fact}{fact}(x) - -\method{fact}{pseudo_id}(x) - -\method{fact}{haven_labelled}(x) -} -\arguments{ -\item{x}{A vector of values} -} -\value{ -A vector of equal length of \code{x} with class \code{fact} and \code{factor}. If -\code{x} was \code{ordered}, that class is added in between. -} -\description{ -Quickly create a factor -} -\details{ -\code{fact()} can be about 5 times quicker than \code{factor()} or -\code{as.factor()} as it doesn't bother sorting the levels for non-numeric data -or have other checks or features. It simply converts a vector to a factor -with all unique values as levels with \code{NA}s included. - -\code{fact.factor()} will perform several checks on a factor to include \code{NA} -levels and to check if the levels should be reordered to conform with the -other methods. The \code{fact.fact()} method simple returns \code{x}. -} -\section{level orders}{ - - -The order of the levels may be adjusted to these rules depending on the class -of \code{x}: -\describe{ -\item{\code{character}}{The order of appearance} -\item{\code{numeric}/\code{integer}/\code{Date}/\code{POSIXt}}{By the numeric order} -\item{\code{logical}}{As \code{TRUE}, \code{FALSE}, then \code{NA} if present} -\item{\code{factor}}{Numeric if levels can be safely converted, otherwise as -they are} -} -} - -\seealso{ -\code{\link[=as_ordered]{as_ordered()}} - -Other factors: -\code{\link{as_ordered}()}, -\code{\link{char2fact}()}, -\code{\link{drop_levels}()}, -\code{\link{fact2char}()}, -\code{\link{fact_na}()} -} -\concept{factors} diff --git a/man/fact2char.Rd b/man/fact2char.Rd index 3f66bb93..8f46e19b 100644 --- a/man/fact2char.Rd +++ b/man/fact2char.Rd @@ -22,10 +22,6 @@ Convert factor columns to characters in a \code{data.frame} \code{\link[=char2fact]{char2fact()}} Other factors: -\code{\link{as_ordered}()}, -\code{\link{char2fact}()}, -\code{\link{drop_levels}()}, -\code{\link{fact_na}()}, -\code{\link{fact}()} +\code{\link{char2fact}()} } \concept{factors} diff --git a/man/fact_na.Rd b/man/fact_na.Rd deleted file mode 100644 index a12e9c9b..00000000 --- a/man/fact_na.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fact.R -\name{fact_na} -\alias{fact_na} -\title{\code{fact} with \code{NA}} -\usage{ -fact_na(x, remove = FALSE) -} -\arguments{ -\item{x}{A \code{fact} or object cohered to \code{fact}} - -\item{remove}{If \code{TRUE} removes \code{NA} value from the \code{fact} \code{levels} and -\code{uniques} attributes} -} -\value{ -A \code{fact} vector -} -\description{ -Included \code{NA} values into \code{fact()} -} -\details{ -This re-formats the \code{x} value so that \code{NA}s are found immediately within the -object rather than accessed through its attributes. -} -\seealso{ -Other factors: -\code{\link{as_ordered}()}, -\code{\link{char2fact}()}, -\code{\link{drop_levels}()}, -\code{\link{fact2char}()}, -\code{\link{fact}()} -} -\concept{factors} diff --git a/man/fact_reverse.Rd b/man/fact_reverse.Rd deleted file mode 100644 index c3aaf460..00000000 --- a/man/fact_reverse.Rd +++ /dev/null @@ -1,14 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fact.R -\name{fact_reverse} -\alias{fact_reverse} -\title{Fact reverse levels} -\usage{ -fact_reverse(x) -} -\arguments{ -\item{x}{A \code{fact} object (or passed to \code{\link[=fact]{fact()}})} -} -\description{ -Reverse the levels of a \code{fact} -} From 9bdc3179e219cc0915e0a52e543b7f3c87144013 Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sun, 16 Oct 2022 23:32:18 -0400 Subject: [PATCH 13/25] [#91] reexport pseudo_id --- R/pseudo-id.R | 84 +-------------------------------------------------- 1 file changed, 1 insertion(+), 83 deletions(-) diff --git a/R/pseudo-id.R b/R/pseudo-id.R index b1c1067c..02926f47 100644 --- a/R/pseudo-id.R +++ b/R/pseudo-id.R @@ -1,83 +1 @@ -#' Create an ID for a vector -#' -#' Transforms a vector into an integer of IDs. -#' -#' @param x A vector of values -#' @param ... Additional arguments passed to methods -#' -#' @returns A `pseudo_id` object where the `integer` value of the vector -#' correspond to the position of the unique values in the attribute `"uniques"`. -#' -#' @examples -#' set.seed(42) -#' (x <- sample(letters, 10, TRUE)) -#' (pid <- pseudo_id(x)) -#' attr(pid, "uniques")[pid] -#' -#' @export -pseudo_id <- function(x, ...) { - UseMethod("pseudo_id", x) -} - -#' @export -#' @rdname pseudo_id -pseudo_id.pseudo_id <- function(x, ...) { - x -} - -#' @export -#' @rdname pseudo_id -#' @param na_last `Logical` if `FALSE` will not place `NA` at the end -pseudo_id.default <- function(x, na_last = TRUE, ...) { - ux <- unique(x) - if (na_last) ux <- na_last(ux) - make_pseudo_id(match(x, ux), ux) -} - -#' @export -#' @rdname pseudo_id -pseudo_id.factor <- function(x, ...) { - pseudo_id(fact_values(fact(x))) -} - -#' Print `pseudo_id` -#' @export -#' @param x An object of class [pseudo_id] -#' @param ... Not implemented -#' @param all if `TRUE` will print all uniques. This is not recommend for many -#' uniques as it will crowd the console output -#' @returns `x`, invisibly. Called for its side effects. -#' @seealso [pseudo_id()] -print.pseudo_id <- function(x, ..., all = FALSE) { - print(as.integer(x)) - out <- collapse0("Uniques: ", paste0(attr(x, "uniques"), sep = " "), sep = "") - if (!all) { - width <- getOption("width", 180) - if (nchar(out) > width) { - out <- substr(out, 1, width - 4) - out <- paste0(out, " ...") - } - } - cat0(out, "\n") - invisible(x) -} - -# helpers ----------------------------------------------------------------- - -make_pseudo_id <- function(x, u) { - struct(x, class = c("pseudo_id", "integer"), uniques = u) -} - -na_last <- function(x) { - if (anyNA(x)) { - nas <- is.na(x) - c(x[!nas], x[nas]) - } else { - x - } -} - -.uniques <- function(x) { - attr(x, "uniques") -} - +pseudo_id <- facts::pseudo_id From e8e4f64848f6675b282e934594bcfa110e1d28fd Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sun, 16 Oct 2022 23:32:24 -0400 Subject: [PATCH 14/25] [#91] redoc --- NAMESPACE | 5 ----- man/print.pseudo_id.Rd | 25 ------------------------- man/pseudo_id.Rd | 38 -------------------------------------- 3 files changed, 68 deletions(-) delete mode 100644 man/print.pseudo_id.Rd delete mode 100644 man/pseudo_id.Rd diff --git a/NAMESPACE b/NAMESPACE index 633d8ee0..4a33360e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -36,14 +36,10 @@ S3method(print,mark_bib_list) S3method(print,mark_environments) S3method(print,note) S3method(print,noted) -S3method(print,pseudo_id) S3method(print,source_env) S3method(print,todos_df) S3method(props,data.frame) S3method(props,default) -S3method(pseudo_id,default) -S3method(pseudo_id,factor) -S3method(pseudo_id,pseudo_id) S3method(remove_labels,data.frame) S3method(remove_labels,default) S3method(remove_na,default) @@ -179,7 +175,6 @@ export(paste_combine) export(percentile_rank) export(print_c) export(props) -export(pseudo_id) export(q50) export(quick_df) export(quick_dfl) diff --git a/man/print.pseudo_id.Rd b/man/print.pseudo_id.Rd deleted file mode 100644 index d1ee9912..00000000 --- a/man/print.pseudo_id.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pseudo-id.R -\name{print.pseudo_id} -\alias{print.pseudo_id} -\title{Print \code{pseudo_id}} -\usage{ -\method{print}{pseudo_id}(x, ..., all = FALSE) -} -\arguments{ -\item{x}{An object of class \link{pseudo_id}} - -\item{...}{Not implemented} - -\item{all}{if \code{TRUE} will print all uniques. This is not recommend for many -uniques as it will crowd the console output} -} -\value{ -\code{x}, invisibly. Called for its side effects. -} -\description{ -Print \code{pseudo_id} -} -\seealso{ -\code{\link[=pseudo_id]{pseudo_id()}} -} diff --git a/man/pseudo_id.Rd b/man/pseudo_id.Rd deleted file mode 100644 index fdb0193f..00000000 --- a/man/pseudo_id.Rd +++ /dev/null @@ -1,38 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pseudo-id.R -\name{pseudo_id} -\alias{pseudo_id} -\alias{pseudo_id.pseudo_id} -\alias{pseudo_id.default} -\alias{pseudo_id.factor} -\title{Create an ID for a vector} -\usage{ -pseudo_id(x, ...) - -\method{pseudo_id}{pseudo_id}(x, ...) - -\method{pseudo_id}{default}(x, na_last = TRUE, ...) - -\method{pseudo_id}{factor}(x, ...) -} -\arguments{ -\item{x}{A vector of values} - -\item{...}{Additional arguments passed to methods} - -\item{na_last}{\code{Logical} if \code{FALSE} will not place \code{NA} at the end} -} -\value{ -A \code{pseudo_id} object where the \code{integer} value of the vector -correspond to the position of the unique values in the attribute \code{"uniques"}. -} -\description{ -Transforms a vector into an integer of IDs. -} -\examples{ -set.seed(42) -(x <- sample(letters, 10, TRUE)) -(pid <- pseudo_id(x)) -attr(pid, "uniques")[pid] - -} From ba3dce7fb4c0ed616c30f3c0d2302b6006857cec Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sun, 16 Oct 2022 23:33:32 -0400 Subject: [PATCH 15/25] [#91] actually reexport --- R/fact.R | 5 +++++ R/pseudo-id.R | 2 ++ 2 files changed, 7 insertions(+) diff --git a/R/fact.R b/R/fact.R index 946779ed..4b539789 100644 --- a/R/fact.R +++ b/R/fact.R @@ -1,20 +1,25 @@ # fact -------------------------------------------------------------------- +#' @export fact <- facts::fact # as_ordered -------------------------------------------------------------- +#' @export as_ordered <- facts::as_ordered # drop_levels ------------------------------------------------------------- +#' @export drop_levels <- facts::drop_levels # fact_na ----------------------------------------------------------------- +#' @export fact_na <- facts::fact_na # fact_reverse ------------------------------------------------------------ +#' @export fact_reverse <- facts:::fact_reverse diff --git a/R/pseudo-id.R b/R/pseudo-id.R index 02926f47..da7db705 100644 --- a/R/pseudo-id.R +++ b/R/pseudo-id.R @@ -1 +1,3 @@ + +#' @export pseudo_id <- facts::pseudo_id From 4f351eef84a9ea42d282c88e51272f94780d947d Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sun, 16 Oct 2022 23:33:37 -0400 Subject: [PATCH 16/25] [#91] redoc --- NAMESPACE | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 4a33360e..47164759 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -75,6 +75,7 @@ export(add_file_timestamp) export(any_match) export(are_identical) export(array_extract) +export(as_ordered) export(assign_labels) export(base_alpha) export(base_n) @@ -101,12 +102,16 @@ export(diff_time_secs) export(diff_time_weeks) export(diff_time_wyears) export(diff_time_years) +export(drop_levels) export(either) export(environments) export(ept) export(eval_named_chunk) export(expand_by) +export(fact) export(fact2char) +export(fact_na) +export(fact_reverse) export(fct_expand_seq) export(file_name) export(file_open) @@ -175,6 +180,7 @@ export(paste_combine) export(percentile_rank) export(print_c) export(props) +export(pseudo_id) export(q50) export(quick_df) export(quick_dfl) From 1dd6044bbb5407edb8ae22bf7084f9207afc5c43 Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sun, 16 Oct 2022 23:34:57 -0400 Subject: [PATCH 17/25] [#91] move reexports to single file --- R/fact.R | 25 ------------------------- R/pseudo-id.R | 3 --- R/reexports.R | 20 ++++++++++++++++++++ 3 files changed, 20 insertions(+), 28 deletions(-) delete mode 100644 R/fact.R delete mode 100644 R/pseudo-id.R create mode 100644 R/reexports.R diff --git a/R/fact.R b/R/fact.R deleted file mode 100644 index 4b539789..00000000 --- a/R/fact.R +++ /dev/null @@ -1,25 +0,0 @@ - -# fact -------------------------------------------------------------------- - -#' @export -fact <- facts::fact - -# as_ordered -------------------------------------------------------------- - -#' @export -as_ordered <- facts::as_ordered - -# drop_levels ------------------------------------------------------------- - -#' @export -drop_levels <- facts::drop_levels - -# fact_na ----------------------------------------------------------------- - -#' @export -fact_na <- facts::fact_na - -# fact_reverse ------------------------------------------------------------ - -#' @export -fact_reverse <- facts:::fact_reverse diff --git a/R/pseudo-id.R b/R/pseudo-id.R deleted file mode 100644 index da7db705..00000000 --- a/R/pseudo-id.R +++ /dev/null @@ -1,3 +0,0 @@ - -#' @export -pseudo_id <- facts::pseudo_id diff --git a/R/reexports.R b/R/reexports.R new file mode 100644 index 00000000..41a59634 --- /dev/null +++ b/R/reexports.R @@ -0,0 +1,20 @@ + +# facts ------------------------------------------------------------------- + +#' @export +pseudo_id <- facts::pseudo_id + +#' @export +fact <- facts::fact + +#' @export +as_ordered <- facts::as_ordered + +#' @export +drop_levels <- facts::drop_levels + +#' @export +fact_na <- facts::fact_na + +#' @export +fact_reverse <- facts:::fact_reverse From 92766f669d6024d7b243f0023bda7c4669bc4178 Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sun, 16 Oct 2022 23:53:39 -0400 Subject: [PATCH 18/25] [#91] maybe actually reexport --- NAMESPACE | 6 ++++++ R/reexports.R | 18 ++++++++++++------ man/reexports.Rd | 10 +++++++++- 3 files changed, 27 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 47164759..04f08ebb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -247,4 +247,10 @@ export(within_call) export(within_fun) export(write_clipboard) export(wuffle) +importFrom(facts,as_ordered) +importFrom(facts,drop_levels) +importFrom(facts,fact) +importFrom(facts,fact_na) +importFrom(facts,fact_reverse) +importFrom(facts,pseudo_id) importFrom(magrittr,"%>%") diff --git a/R/reexports.R b/R/reexports.R index 41a59634..7b9d1d05 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -2,19 +2,25 @@ # facts ------------------------------------------------------------------- #' @export -pseudo_id <- facts::pseudo_id +#' @importFrom facts pseudo_id +facts::pseudo_id #' @export -fact <- facts::fact +#' @importFrom facts fact +facts::fact #' @export -as_ordered <- facts::as_ordered +#' @importFrom facts as_ordered +facts::as_ordered #' @export -drop_levels <- facts::drop_levels +#' @importFrom facts drop_levels +facts::drop_levels #' @export -fact_na <- facts::fact_na +#' @importFrom facts fact_na +facts::fact_na #' @export -fact_reverse <- facts:::fact_reverse +#' @importFrom facts fact_reverse +facts::fact_reverse diff --git a/man/reexports.Rd b/man/reexports.Rd index 5eefe054..75794df6 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -1,8 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/reexports.R, R/utils.R \docType{import} \name{reexports} \alias{reexports} +\alias{pseudo_id} +\alias{fact} +\alias{as_ordered} +\alias{drop_levels} +\alias{fact_na} +\alias{fact_reverse} \alias{\%>\%} \title{Objects exported from other packages} \keyword{internal} @@ -11,6 +17,8 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ + \item{facts}{\code{\link[facts]{as_ordered}}, \code{\link[facts]{drop_levels}}, \code{\link[facts]{fact}}, \code{\link[facts]{fact_na}}, \code{\link[facts]{fact_reverse}}, \code{\link[facts]{pseudo_id}}} + \item{magrittr}{\code{\link[magrittr:pipe]{\%>\%}}} }} From 10e98ce5ce8fb735fd738bca0c9710fef688b9be Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Mon, 31 Oct 2022 10:26:44 -0400 Subject: [PATCH 19/25] [#91] remove tests for {facts} --- tests/testthat/test-fact.R | 388 -------------------------------- tests/testthat/test-pseudo_id.R | 61 ----- 2 files changed, 449 deletions(-) delete mode 100644 tests/testthat/test-fact.R delete mode 100644 tests/testthat/test-pseudo_id.R diff --git a/tests/testthat/test-fact.R b/tests/testthat/test-fact.R deleted file mode 100644 index 8f6f6d26..00000000 --- a/tests/testthat/test-fact.R +++ /dev/null @@ -1,388 +0,0 @@ -# fact.default() ---- - -test_that("fact.default() works", { - x <- struct(1, "foo") - expect_warning(res <- fact(x)) - expect_identical(res, fact(as.character(x))) -}) - -# fact.logical() ---- - -test_that("fact.logical() works", { - x <- fact(c(TRUE, FALSE, NA)) - expect_message(capture.output(print(x)), NA) - - x <- fact(c(FALSE, NA, NA, TRUE, FALSE)) - res <- new_fact(c(2L, 3L, 3L, 1L, 2L), c(TRUE, FALSE, NA)) - expect_identical(x, res) - - expect_false(anyNA(x)) -}) - -# fact.pseudo_id() ---- - -test_that("fact.pseudo_id() works", { - expect_message(capture.output(print(fact(pseudo_id(c("a", "a", "b", NA_character_))))), NA) - - # Should appropriately order numeric values - x <- c(0L, 10L, 10L, NA, 0L, 5L) - id <- pseudo_id(x) - f <- fact(id) - res <- new_fact(c(1L, 3L, 3L, 4L, 1L, 2L), c(0L, 5L, 10L, NA_integer_)) - - expect_identical(fact(x), f) - expect_identical(fact(x), res) - - # Shouldn't have any NA - expect_false(anyNA(fact(x))) - - # pseudo_id() ordered by appearance, fact() has pre-set ordering - expect_identical(pseudo_id(f), id) - - # attr(id, "uniques") <- as.character(attr(id, "uniques")) - # factors store levels as characters - o <- order(as.integer(levels(f))) - expect_identical(o, 1:4) -}) - -# fact.integer() ---- - -test_that("fact.integer() works", { - expect_equal( - fact(struct(1L, c("foo", "integer"))), - new_fact(1L, levels = 1L) - ) -}) - -# fact.factor() ---- - -test_that("fact.factor() works", { - # x <- fact(as.character(c(Sys.Date() + 5:1, NA))[sample(1:6, 20, TRUE)]) - - x <- factor(letters) - class(x) <- c("fact", "factor") - expect_identical(fact(x), x) - - x <- ordered(letters) - class(x) <- c("fact", "ordered", "factor") - expect_identical(fact(x), x) - - x <- struct(1L, c("fact", "factor"), levels = c("a", NA_character_)) - expect_identical(fact(x), x) - - # fact.fact() checks for NA and adds - x <- factor(c(1, NA, 2)) - expect_identical(levels(fact(x)), c("1", "2", NA_character_)) - - # moves NA to the end and reordered when number - x <- factor(c(1, NA, 2), levels = c(2, NA, 1), exclude = NULL) - res <- new_fact(c(1, 3, 2), levels = c(1, 2, NA)) - expect_identical(fact(x), res) - - x <- factor(c(NA, TRUE, FALSE)) - res <- new_fact(c(3L, 1L, 2L), levels = c(TRUE, FALSE, NA)) - expect_identical(fact(x), res) - - x <- factor(c(NA, TRUE, FALSE), exclude = NULL) - res <- new_fact(c(3L, 1L, 2L), levels = c(TRUE, FALSE, NA)) - expect_identical(fact(x), res) -}) - -# fact.haven_labelled() ---- - -test_that("fact.haven_labelled() works", { - skip_if_not_installed("haven") - .haven_as_factor <- "haven" %colons% "as_factor.haven_labelled" - haven_as_fact <- function(...) { - res <- fact(.haven_as_factor(...)) - attr(res, "label") <- exattr(..1, "label") - res - } - - expect_id_fact <- function(x) { - testthat::expect_identical( - fact(x), - haven_as_fact(x), - ignore_attr = c("uniques", "na") - ) - } - - # Integers - r <- rep(1:3, 2) - x <- haven::labelled(r, labels = c(good = 1, bad = 3)) - expect_id_fact(x) - - x <- haven::labelled(r, labels = c(good = 1, bad = 3), label = "this") - expect_id_fact(x) - - x <- haven::labelled(r, labels = c(good = 1, neutral = 2, bad = 3), label = "this") - expect_id_fact(x) - - x <- haven::labelled(r, label = "this") - expect_id_fact(x) - - # Doubles - x <- haven::labelled(c(0, 0.5, 1), c(a = 0, b = 1)) - expect_id_fact(x) - - # Character - x <- haven::labelled(letters, c(good = "j", something = "m", cool = "b")) - expect_id_fact(x) - - # Unique not in levels; levels not in unique - x <- haven::labelled( - c(-10, 20, 40, 60), - labels = c(a = 10, b = 20, c = 30, d = 40), - label = "foo" - ) - expect_id_fact(x) -}) - -# nas ---- - -test_that("fact() correctly labels NAs [#24]", { - expect_equal( - fact(c(NA, "a", "b")), - new_fact(c(3L, 1L, 2L), c("a", "b", NA)) - ) - - expect_equal( - fact(c(NA, 1, 3)), - new_fact(c(3L, 1L, 2L), c(1, 3, NA)) - ) - - expect_equal( - fact(c(1, NA, NA, 3)), - new_fact(c(1L, 3L, 3L, 2L), c(1, 3, NA)) - ) - - expect_equal( - fact(c(TRUE, TRUE, NA, FALSE, TRUE)), - new_fact(c(1L, 1L, 3L, 2L, 1L), c(TRUE, FALSE, NA)) - ) -}) - - -test_that("fact() ignores NaN", { - # ignore NaN - res <- fact(c(1, 2, NA, 3, NaN)) - exp <- struct( - c(1L, 2L, 4L, 3L, 4L), - class = c("fact", "factor"), - levels = c("1", "2", "3", NA), - uniques = c(1, 2, 3, NA), - na = 4L - ) - - expect_identical(res, exp) -}) - - -# ordering ---- - -test_that("as_ordered() works", { - res <- fact(c(1:3, NA_integer_)) - exp <- struct( - c(1:3, NA_integer_), - c("fact", "ordered", "factor"), - levels = as.character(1:3), - uniques = 1:3, - na = 0L - ) - expect_identical(as_ordered(res), exp) -}) - -test_that("as_ordered() doesn't duplicate class", { - res <- class(as_ordered(as.ordered(letters[1:3]))) - expect_identical(res, c("fact", "ordered", "factor")) -}) - - -# fact.default() ---------------------------------------------------------- - -test_that("fact.default() fails", { - expect_error(fact(struct(NULL, "foo"))) -}) - - -# `fact_levels<-`() ------------------------------------------------------- - -test_that("`fact_levels<-`() works", { - x <- fact(1:3) - fact_levels(x) <- 1:4 - exp <- struct( - 1:3, - class = c("fact", "factor"), - levels = as.character(1:4), - uniques = 1:4, - na = 0L - ) - expect_identical(x, exp) -}) - - -# fact_coerce_levels() ---------------------------------------------------- - -test_that("fact_coerce_levels() works", { - x <- as.Date("2021-09-03") + 0:2 - expect_equal(fact_coerce_levels(as.character(x)), x) - - # Be careful about setting a time zone - # Not very good for dealing with local - # NOTE r-dev after 4.2.1 has some weird behavior with the 0 and returns: - # ('2021-09-03', '2021-09-03 00:00:01', '2021-09-03 00:00:02') - x <- as.POSIXlt("2021-09-03", tz = "UTC") + 1:3 - expect_equal(fact_coerce_levels(as.character(x)), x) - - x <- as.POSIXlt("2021-09-03", tz = "UTC") + 1:3 - expect_equal(fact_coerce_levels(as.character(x)), x) -}) - - -# try_numeric() ----------------------------------------------------------- - -test_that("try_numeric() works", { - x <- 1 - expect_identical(try_numeric(x), x) - - x <- c(NA, NA) - expect_identical(try_numeric(x), x) - - x <- c("a", 1) - expect_identical(try_numeric(x), x) - - x <- c(1, NA, 2) - expect_identical(try_numeric(as.character(x)), x) -}) - - -# drop_levels ------------------------------------------------------------- - -test_that("drop_levels() works", { - x <- factor(1, 1:2) - exp <- factor(1, 1) - expect_equal(drop_levels(x), exp) - - df <- quick_dfl(x = x, y = 1) - df_exp <- quick_dfl(x = exp, y = 1) - expect_equal(drop_levels(df), df_exp) - - # facts and ordered - x <- fact(1:10) - expect_identical(drop_levels(x), x) - - x <- as_ordered(factor(1, 1:2)) - exp <- struct(1L, class = c("fact", "ordered", "factor"), levels = "1", uniques = 1L, na = 0L) - expect_equal(drop_levels(x), exp) -}) - - -# fact_reverse() ---------------------------------------------------------- - -test_that("fact_reverse() works", { - res <- fact_reverse(1:4) - exp <- new_fact(4:1, 4:1) - expect_identical(res, exp) - - res <- fact_reverse(as_ordered(1:4)) - exp <- new_fact(4:1, 4:1, ordered = TRUE) - expect_identical(res, exp) - - res <- fact_reverse(c(1:3, NA)) - exp <- new_fact(c(3:1, 4L), c(3:1, NA)) - expect_identical(res, exp) - - res <- fact_reverse(as_ordered(c(1:3, NA))) - exp <- struct( - c(3:1, NA), - class = c("fact", "ordered", "factor"), - levels = c("3", "2", "1"), - uniques = 3:1, - na = 0L - ) - - expect_identical(res, exp) -}) - - - -# other methods ----------------------------------------------------------- - -test_that("[.fact() works", { - x <- fact(1:3) - x1 <- do.call(structure, c(1, attributes(x))) - x2 <- do.call(structure, c(2, attributes(x))) - expect_identical(x[1], x1) - expect_identical(x[2], x2) -}) - -test_that("is.na.fact(), works", { - x <- fact(c(1, 2, NA, 3)) - res <- is.na(x) - exp <- c(FALSE, FALSE, FALSE, FALSE) - expect_identical(res, exp) - - x <- fact_na(c(1, 2, NA, 3)) - res <- is.na(x) - exp <- c(FALSE, FALSE, TRUE, FALSE) - expect_identical(res, exp) - - x <- fact_na(c("a", "b", "c")) - res <- is.na(x) - exp <- c(FALSE, FALSE, FALSE) - expect_identical(res, exp) -}) - -test_that("as.integer.fact() works", { - x <- fact(c(1, 2, NA, 3)) - res <- as.integer(x) - exp <- c(1L, 2L, NA_integer_, 3L) - expect_identical(res, exp) -}) - -test_that("as.integer.fact() works", { - x <- fact(c(1, 2, NA, 3)) - res <- as.double(x) - exp <- c(1, 2, NA_real_, 3) - expect_identical(res, exp) - expect_identical(as.numeric(x), exp) -}) - -test_that("unique.fact() works", { - x <- fact(c(1, 2, NA, 3, 2)) - exp <- fact(c(1, 2, NA, 3)) - res <- unique(x) - expect_identical(exp, res) - - x <- as_ordered(x) - exp <- as_ordered(exp) - res <- unique(x) - expect_identical(exp, res) -}) - -test_that("as.Date.fact() works", { - exp <- as.Date(c("2022-01-02", NA, "1908-12-21")) - res <- as.Date(fact(exp)) - expect_identical(exp, res) - - x <- c("01-01-2022", "01-02-2000") - exp <- as.Date(x, "%d-%m-%Y") - res <- as.Date(fact(x), "%d-%m-%Y") - expect_identical(exp, res) -}) - -test_that("as.character.fact() works", { - exp <- c("a", NA_character_, "b", "b", "a") - res <- as.character(fact(exp)) - expect_identical(exp, res) -}) - -# snapshots --------------------------------------------------------------- - -test_that("snapshots", { - expect_snapshot(fact(character())) - expect_snapshot(fact(1:5)) - expect_snapshot(print(fact(1:100), max_levels = TRUE)) - expect_snapshot(print(fact(1:100), max_levels = 20)) - expect_snapshot(print(fact(1:100), max_levels = 100)) -}) diff --git a/tests/testthat/test-pseudo_id.R b/tests/testthat/test-pseudo_id.R deleted file mode 100644 index 405a1b11..00000000 --- a/tests/testthat/test-pseudo_id.R +++ /dev/null @@ -1,61 +0,0 @@ -test_that("pseudo_id.default() works", { - x <- c(1L, 1L, 4L, NA_integer_, 2L) - res <- pseudo_id(x) - - expect_identical( - res, - struct( - c(1L, 1L, 2L, 4L, 3L), - uniques = c(1L, 4L, 2L, NA_integer_), - class = c("pseudo_id", "integer")) - ) - - x <- c(1.2, 1.2, 4.999, NA, -2) - res <- pseudo_id(x) - - expect_identical( - res, - struct( - c(1L, 1L, 2L, 4L, 3L), - uniques = c(1.2, 4.999, -2, NA_real_), - class = c("pseudo_id", "integer")) - ) -}) - -test_that("pseudo_id.factor() works", { - x <- struct(1:3, levels = letters[1:3], class = "factor") - res <- pseudo_id(x) - exp <- struct(1:3, uniques = letters[1:3], class = c("pseudo_id", "integer")) - expect_identical(res, exp) -}) - -test_that("pseudo_id.factor() does not return NA values [#28]", { - # NA in levels and values - x <- struct(c(1:3, NA), levels = c(letters[1:3], NA), class = "factor") - res <- pseudo_id(x) - exp <- struct(1:4, uniques = c(letters[1:3], NA_character_), class = c("pseudo_id", "integer")) - expect_identical(res, exp) - - # NA in values but not in levels - x <- struct(c(1:3, NA), levels = letters[1:3], class = "factor") - res <- pseudo_id(x) - exp <- struct(1:4, uniques = c(letters[1:3], NA_character_), class = c("pseudo_id", "integer")) - expect_identical(res, exp) -}) - -test_that("pseudo_id.pseudo_id() works", { - x <- runif(10) - x <- round(x, 2) - id <- pseudo_id(x) - expect_equal(pseudo_id(id), id) -}) - -test_that("snapshots", { - x <- c( - 0.316596544580534, 0.838568194536492, 0.126674774102867, - 0.657560844207183, 0.636712728533894, 0.571150240721181, - 0.0811728567350656, 0.765485385898501, 0.562053531175479, - 0.807950841495767, 0.00996402697637677, 0.825092894025147 - ) - expect_snapshot(pseudo_id(x)) -}) From 753c105468af2f70907a2500dcf36a43938f5c72 Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Mon, 31 Oct 2022 10:27:16 -0400 Subject: [PATCH 20/25] [#91] uniques to values --- R/char2fact.R | 2 +- R/counts.R | 2 +- R/percent_rank.R | 2 +- R/unlist.R | 2 +- tests/testthat/test-nas.R | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/R/char2fact.R b/R/char2fact.R index a2b05c94..eb7e8038 100644 --- a/R/char2fact.R +++ b/R/char2fact.R @@ -22,7 +22,7 @@ char2fact.default <- function(x, n = 5) { char2fact.character <- function(x, n = 5) { id <- pseudo_id(x) - if (length(.uniques(id)) <= n) { + if (length(attr(id, "values")) <= n) { x <- fact(id) } diff --git a/R/counts.R b/R/counts.R index 1d5d312a..afc4a1ba 100644 --- a/R/counts.R +++ b/R/counts.R @@ -50,7 +50,7 @@ counts <- function(x, ...) { #' @export counts.default <- function(x, sort = FALSE, ...) { x <- pseudo_id(x) - u <- .uniques(x) + u <- attr(x, "values") out <- tabulate(x, length(u)) names(out) <- na_last(u) diff --git a/R/percent_rank.R b/R/percent_rank.R index baa695fc..e65f1b06 100644 --- a/R/percent_rank.R +++ b/R/percent_rank.R @@ -58,7 +58,7 @@ percentile_rank <- function(x, weights = times, times) { id <- pseudo_id(x) tab <- counts(id) - key <- attr(id, "uniques") + key <- attr(id, "values") res <- set_names0(do_percentile_rank(key, tab), NULL) set_names0(res[match(x, key)], x) } diff --git a/R/unlist.R b/R/unlist.R index 360d4d9a..210a789e 100644 --- a/R/unlist.R +++ b/R/unlist.R @@ -36,5 +36,5 @@ squash_vec <- function(x, sep = ".") { id <- pseudo_id(x, na_last = FALSE) nm <- names(x) squasher <- function(i) collapse0(nm[i], sep = sep) - .uniques(id) %names% vap_chr(split(seq_along(id), id), squasher) + attr(id, "values") %names% vap_chr(split(seq_along(id), id), squasher) } diff --git a/tests/testthat/test-nas.R b/tests/testthat/test-nas.R index 082543bc..476bdb0c 100644 --- a/tests/testthat/test-nas.R +++ b/tests/testthat/test-nas.R @@ -9,7 +9,7 @@ test_that("remove_na()", { 1:3, c("fact", "factor"), levels = c("1", "2", "3"), - uniques = c(1, 2, 3), + values = c(1, 2, 3), na = 0L ) From 5ba13cb6f26de09b7404a498287b6b48a90f7702 Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Mon, 31 Oct 2022 10:27:27 -0400 Subject: [PATCH 21/25] [#91] na_last() from {facts} --- R/counts.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/counts.R b/R/counts.R index afc4a1ba..229ec96c 100644 --- a/R/counts.R +++ b/R/counts.R @@ -52,7 +52,8 @@ counts.default <- function(x, sort = FALSE, ...) { x <- pseudo_id(x) u <- attr(x, "values") out <- tabulate(x, length(u)) - names(out) <- na_last(u) + nas <- is.na(u) + names(out) <- c(u[!nas], u[nas]) if (sort) { return(sort_names(out, numeric = is.numeric(x))) From 263f9fde1aa1d82dea83830445785bc615866b5a Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sat, 16 May 2026 18:05:05 -0400 Subject: [PATCH 22/25] bring in updates (#91) --- .Rbuildignore | 5 + .gitignore | 1 + DESCRIPTION | 92 +++++++++++++++- NAMESPACE | 72 ++++++++++--- R/fact.R | 287 ++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 439 insertions(+), 18 deletions(-) create mode 100644 R/fact.R diff --git a/.Rbuildignore b/.Rbuildignore index c7d15d39..226943ba 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -17,3 +17,8 @@ revdep ^docs$ ^pkgdown$ ^CRAN-SUBMISSION$ +^\.lintr$ +^\.git$ +^air\.toml$ +^\.positai$ +^\.claude$ diff --git a/.gitignore b/.gitignore index 63df67f5..acf8ae5a 100644 --- a/.gitignore +++ b/.gitignore @@ -46,3 +46,4 @@ revdep/checks/libraries.csv revdep/data.sqlite tests/testthat/Rplots.pdf docs +.positai diff --git a/DESCRIPTION b/DESCRIPTION index ec1c55d8..c85af08d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,7 +21,11 @@ LazyData: true Depends: R (>= 3.6) Imports: - facts, + cli, + cnd, + fs (>= 0.2.0), + fuj, + generics, magrittr (>= 2.0.1), stats (>= 3.6), tools (>= 3.6), @@ -43,11 +47,89 @@ Suggests: testthat (>= 3.0.0), tibble (>= 3.0.4), waldo (>= 0.2.5), - withr (>= 2.3.0) -RoxygenNote: 7.2.1 + withr (>= 2.3.0), + xopen, + yaml (>= 2.3.9), +Remotes: + github::jmbarbone/cnd@v0.1.1.9002, + github::jmbarbone/fuj@v0.2.2.9011 Roxygen: list(markdown = TRUE) Config/testthat/edition: 3 Config/testthat/parallel: true Language: en-US -VignetteBuilder: knitr -Remotes: github::jmbarbone/facts +Collate: + 'aaa.R' + 'append.R' + 'apply.R' + 'array.R' + 'base-conversion.R' + 'bib.R' + 'blank.R' + 'boolean.R' + 'char2fact.R' + 'clipboard.R' + 'counts.R' + 'dataframes.R' + 'dates.R' + 'depth.R' + 'description.R' + 'detail.R' + 'diff-time.R' + 'directory.R' + 'environments.R' + 'expand.R' + 'fact.R' + 'fct-expand-seq.R' + 'file.R' + 'fizzbuzz.R' + 'funs.R' + 'glob.R' + 'handlers.R' + 'identical.R' + 'import.R' + 'insert.R' + 'labels.R' + 'limit.R' + 'lines-of-code.R' + 'logic.R' + 'map.R' + 'mark-cnd-conditions.R' + 'not-available.R' + 'mark-package.R' + 'match-arg.R' + 'md5.R' + 'merge-list.R' + 'na-assignment.R' + 'names.R' + 'namespace.R' + 'nas.R' + 'normalize.R' + 'note.R' + 'options.R' + 'paste.R' + 'percentile-rank.R' + 'plot.R' + 'pseudo-id.R' + 'read.R' + 'recode.R' + 'reexports-fuj.R' + 'reexports-magrittr.R' + 'round-by.R' + 'round.R' + 'row-bind.R' + 'searches.R' + 'sort-by.R' + 'sourcing.R' + 'stats.R' + 'strings.R' + 'switch.R' + 'system-file.R' + 'time-report.R' + 'todos.R' + 'tryn.R' + 'unlist.R' + 'utils.R' + 'within.R' + 'write.R' + 'zzz.R' +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index 04f08ebb..d223dc90 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,6 +3,8 @@ S3method(append0,data.frame) S3method(append0,default) S3method(append0,list) +S3method(as.factor,fact) +S3method(as.ordered,fact) S3method(assign_labels,data.frame) S3method(assign_labels,default) S3method(char2fact,character) @@ -17,9 +19,16 @@ S3method(depth,default) S3method(depth,list) S3method(detail,data.frame) S3method(detail,default) -S3method(flip,data.frame) -S3method(flip,default) -S3method(flip,matrix) +S3method(fact,Date) +S3method(fact,POSIXct) +S3method(fact,POSIXlt) +S3method(fact,character) +S3method(fact,default) +S3method(fact,fact) +S3method(fact,factor) +S3method(fact,integer) +S3method(fact,logical) +S3method(fact,numeric) S3method(get_labels,data.frame) S3method(get_labels,default) S3method(is_false,default) @@ -60,6 +69,7 @@ export("%out%") export("%wi%") export("%wo%") export("%xor%") +export("converter<-") export("note<-") export(.fizzbuzz_vector) export(AND) @@ -75,7 +85,10 @@ export(add_file_timestamp) export(any_match) export(are_identical) export(array_extract) -export(as_ordered) +export(as.factor) +export(as.ordered) +export(as.values) +export(as_values) export(assign_labels) export(base_alpha) export(base_n) @@ -87,6 +100,7 @@ export(checkOptions) export(chr_split) export(collapse0) export(complete_cases) +export(converter) export(counts) export(date_from_partial) export(depth) @@ -102,7 +116,6 @@ export(diff_time_secs) export(diff_time_weeks) export(diff_time_wyears) export(diff_time_years) -export(drop_levels) export(either) export(environments) export(ept) @@ -110,8 +123,6 @@ export(eval_named_chunk) export(expand_by) export(fact) export(fact2char) -export(fact_na) -export(fact_reverse) export(fct_expand_seq) export(file_name) export(file_open) @@ -134,8 +145,13 @@ export(has_message) export(has_warning) export(import) export(insert) +export(is.fact) +export(isNA) +export(is_blank) +export(is_blank_cols) export(is_boolean) export(is_dir) +export(is_fact) export(is_false) export(is_file) export(is_na_cols) @@ -234,6 +250,7 @@ export(unlist0) export(update_version) export(use_author) export(user_file) +export(values) export(vap_chr) export(vap_cplx) export(vap_date) @@ -247,10 +264,39 @@ export(within_call) export(within_fun) export(write_clipboard) export(wuffle) -importFrom(facts,as_ordered) -importFrom(facts,drop_levels) -importFrom(facts,fact) -importFrom(facts,fact_na) -importFrom(facts,fact_reverse) -importFrom(facts,pseudo_id) +export(xnandr) +import(cnd) +import(fuj) +importFrom(cnd,class_error) +importFrom(cnd,input_error) +importFrom(cnd,input_warning) +importFrom(cnd,type_error) +importFrom(cnd,value_error) +importFrom(fuj,"%::%") +importFrom(fuj,"%:::%") +importFrom(fuj,"%colons%") +importFrom(fuj,"%len%") +importFrom(fuj,"%names%") +importFrom(fuj,"%out%") +importFrom(fuj,"%wi%") +importFrom(fuj,"%wo%") +importFrom(fuj,"%||%") +importFrom(fuj,any_match) +importFrom(fuj,exattr) +importFrom(fuj,flip) +importFrom(fuj,is_linux) +importFrom(fuj,is_macos) +importFrom(fuj,is_named) +importFrom(fuj,is_windows) +importFrom(fuj,muffle) +importFrom(fuj,no_match) +importFrom(fuj,quick_df) +importFrom(fuj,quick_dfl) +importFrom(fuj,remove_names) +importFrom(fuj,require_namespace) +importFrom(fuj,set_names) +importFrom(fuj,struct) +importFrom(fuj,wuffle) +importFrom(generics,as.factor) +importFrom(generics,as.ordered) importFrom(magrittr,"%>%") diff --git a/R/fact.R b/R/fact.R new file mode 100644 index 00000000..4f91e477 --- /dev/null +++ b/R/fact.R @@ -0,0 +1,287 @@ +# NOTE: I'll need to document this separately. Something about changing the +# scope so it's very limited + +# fact -------------------------------------------------------------------- + +#' Factor +#' +#' Quickly create a factor +#' +#' @details [mark::fact()] can be about 5 times quicker than [base::factor()] or +#' [base::as.factor()] as it doesn't bother sorting the levels for non-numeric +#' data or have other checks or features. It simply converts a vector to a +#' factor with all unique values as levels with `NA`s included. +#' +#' [mark::fact.factor()] will perform several checks on a factor to include +#' `NA` levels and to check if the levels should be reordered to conform with +#' the other methods. The [mark::fact.fact()] method simple returns `x`. +#' +#' @section level orders: +#' +#' The order of the levels may be adjusted to these rules depending on the +#' class of `x`: +#' \describe{ +#' \item{`character`}{The order of appearance} +#' \item{`numeric`/`integer`/`Date`/`POSIXt`}{By the numeric order} +#' \item{`logical`}{As `TRUE`, `FALSE`, then `NA` if present} +#' \item{`factor`}{Numeric if levels can be safely converted, otherwise as +#' they are} +#' } +#' +#' @param x A vector of values +#' @return A vector of equal length of `x` with class `fact` and `factor`. If +#' `x` was `ordered`, that class is added in between. +#' +#' @seealso [mark::as_ordered()] +#' @family factors +#' @export +fact <- function(x) { + UseMethod("fact", x) +} + +#' @rdname fact +#' @export +fact.default <- function(x) { + stop(class_error(x = x, "there is no fact method for this class")) +} + +#' @rdname fact +#' @export +fact.character <- function(x) { + u <- unique(x) + if (anyNA(u)) { + m <- match(NA, u) + if (move_na_last()) { + u <- c(u[-m], NA) + } else { + u <- c(NA, u[-m]) + } + } + new_fact(match(x, u), u, identity) +} + +#' @rdname fact +#' @export +fact.numeric <- function(x) { + fact_numeric(x, as.numeric) +} + +#' @rdname fact +#' @export +fact.integer <- function(x) { + fact_numeric(x, as.integer) +} + +#' @rdname fact +#' @export +fact.Date <- function(x) { + fact_numeric(x, as.Date) +} + +#' @rdname fact +#' @export +fact.POSIXct <- function(x) { + fact_numeric(x, as.POSIXct) +} + +#' @rdname fact +#' @export +fact.POSIXlt <- function(x) { + fact_numeric(x, as.POSIXlt) +} + +#' @rdname fact +#' @export +fact.logical <- function(x) { + u <- if (move_na_last()) c(FALSE, TRUE, NA) else c(NA, FALSE, TRUE) + u <- u[u %in% x] + new_fact(match(x, u), u, as.logical) +} + +#' @rdname fact +#' @export +fact.factor <- function(x) { + old <- levels(x) + old <- utils::type.convert(old, as.is = TRUE, tryLogical = FALSE) + if (is.character(old)) { + maybe <- as.POSIXlt(x, optional = TRUE) + if (!all(is.na(maybe))) { + old <- maybe + } + } + o <- order(old, na.last = move_na_last()) + new <- old[o] + x <- match(old, new)[x] + for (c in class(old)) { + fun <- get0(sprintf("as.%s", c)) + if (!is.null(fun)) { + break + } + } + new_fact(x, new, fun %||% identity) +} + +#' @rdname fact +#' @export +fact.fact <- function(x) { + x +} + +# others ------------------------------------------------------------------ + +#' @export +#' @name fact +as_values <- function(x) { + values(x)[x] +} + +#' @export +#' @name fact +as.values <- as_values # nolint: object_name_linter. + +#' @export +#' @name fact +values <- function(x) { + converter(x)(levels(x)) +} + +#' @export +#' @name fact +converter <- function(x) { + exattr(x, "converter") +} + +#' @export +#' @name fact +`converter<-` <- function(x, value) { + attr(x, "converter") <- match.fun(value) +} + +#' @export +#' @name fact +is_fact <- function(x) { + inherits(x, "fact") +} + +#' @export +#' @name fact +is.fact <- is_fact # nolint: object_name_linter. + +# helpers ----------------------------------------------------------------- + +new_fact <- function(x, levels, fun) { + levels(x) <- as.character(levels) + converter(x) <- fun + # assign "factor" class _after_ levels() + class(x) <- c("fact", "factor") + x +} + + +fact_numeric <- function(x, converter) { + u <- unique(x) + u <- u[order(u, method = "radix", na.last = move_na_last())] + l <- as.character(u) + d <- !duplicated(l) + u <- u[d] + l <- l[d] + new_fact(match(x, u), l, converter) +} + + +move_na_last <- function() { + switch( + as.character(getOption("mark.fact.na.position", "first")), + first = FALSE, + last = TRUE, + stop(value_error( + "options(mark.fact.na.position) must be 'first' or 'last'" + )) + ) +} + + +# other methods ----------------------------------------------------------- + +#' @importFrom generics as.ordered +#' @export +generics::as.ordered + +#' @importFrom generics as.factor +#' @export +generics::as.factor + +#' @export +as.ordered.fact <- function(x) { + if (is.ordered(x)) { + return(x) + } + v <- values(x) + class(x) <- c("ordered", class(x)) + values(x) <- v + x +} + +#' @export +as.factor.fact <- function(x) { + struct(x, c(if (is.ordered(x)) "ordered", "factor"), levels = levels(x)) +} + +#' @export +print.fact <- function( + x, + max_levels = getOption("mark.fact.max_levels", TRUE), + width = getOption("width"), + ... +) { + # mostly a reformatted base::print.factor() + ord <- is.ordered(x) + if (length(x) == 0L) { + cat(if (ord) "ordered" else "factor", "(0)\n", sep = "") + } else { + print(as.character(x), quote = FALSE, ...) + } + + if (max_levels) { + lev <- encodeString(levels(x), quote = "") + n <- length(lev) + colsep <- if (ord) " < " else " " + # instead of "Labels: " + T0 <- "Values: " # nolint: object_name_linter. + if (is.logical(max_levels)) { + max_levels <- { + width <- width - (nchar(T0, "w") + 3L + 1L + 3L) + lenl <- cumsum(nchar(lev, "w") + nchar(colsep, "w")) + + if (n <= 1L || lenl[n] <= width) { + n + } else { + max(1L, which.max(lenl > width) - 1L) + } + } + } + drop <- n > max_levels + cat( + if (drop) paste(format(n), ""), + T0, + paste( + if (drop) { + c(lev[1:max(1L, max_levels - 1L)], "...", if (max_levels > 1L) lev[n]) + } else { + lev + }, + collapse = colsep + ), + "\n", + sep = "" + ) + + # Be nice to haven_labelled + # lab <- exattr(x, "label") + # if (!is.null(lab)) { + # cat("Label: ", paste(format(lab), ""), "\n", sep = "") + # } + } + + invisible(x) +} From dbf48e14f50a76838ccf9383c2474ba504f8f37f Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sat, 16 May 2026 18:09:20 -0400 Subject: [PATCH 23/25] redocs (#91) --- R/reexports.R | 26 -------------------------- man/clipboard.Rd | 4 ++-- man/diff_time.Rd | 2 +- man/file_copy_md5.Rd | 2 +- man/fizzbuzz.Rd | 5 ----- man/is_dir.Rd | 2 +- man/logic_ext.Rd | 4 ++-- man/mark.Rd | 5 +++++ man/median2.Rd | 2 +- man/multi_grepl.Rd | 4 ++-- man/not_available.Rd | 9 --------- man/package_available.Rd | 2 +- man/pseudo_id.Rd | 38 ++++++++++++++++++++++++++++++++++++++ man/range2.Rd | 4 ++-- man/row_bind.Rd | 2 +- man/sourcing.Rd | 2 +- man/switch-ext.Rd | 2 +- man/tableNA.Rd | 7 ++++--- man/vap.Rd | 4 ++-- man/write_file_md5.Rd | 4 ++-- 20 files changed, 67 insertions(+), 63 deletions(-) delete mode 100644 R/reexports.R create mode 100644 man/pseudo_id.Rd diff --git a/R/reexports.R b/R/reexports.R deleted file mode 100644 index 7b9d1d05..00000000 --- a/R/reexports.R +++ /dev/null @@ -1,26 +0,0 @@ - -# facts ------------------------------------------------------------------- - -#' @export -#' @importFrom facts pseudo_id -facts::pseudo_id - -#' @export -#' @importFrom facts fact -facts::fact - -#' @export -#' @importFrom facts as_ordered -facts::as_ordered - -#' @export -#' @importFrom facts drop_levels -facts::drop_levels - -#' @export -#' @importFrom facts fact_na -facts::fact_na - -#' @export -#' @importFrom facts fact_reverse -facts::fact_reverse diff --git a/man/clipboard.Rd b/man/clipboard.Rd index 0220579d..605db20f 100644 --- a/man/clipboard.Rd +++ b/man/clipboard.Rd @@ -43,7 +43,7 @@ read_clipboard_methods() \itemize{ \item \code{\link[=write_clipboard]{write_clipboard()}} None, called for side effects \item \code{\link[=read_clipboard]{read_clipboard()}} Either a vector, \code{data.frame}, or \code{tibble} -depending on the \code{method} chosen. Unlike \code{\link[utils:clipboard]{utils::readClipboard()}}, an +depending on the \code{method} chosen. Unlike \code{\link[utils:readClipboard]{utils::readClipboard()}}, an empty clipboard value returns \code{NA} rather than \code{""} } } @@ -52,7 +52,7 @@ Wrappers for working with the clipboard } \details{ As these functions rely on \code{\link[clipr:read_clip]{clipr::read_clip()}} and -\code{\link[utils:clipboard]{utils::writeClipboard()}} they are only available for Windows 10. For +\code{\link[utils:writeClipboard]{utils::writeClipboard()}} they are only available for Windows 10. For copying and pasting floats, there may be some rounding that can occur. } \examples{ diff --git a/man/diff_time.Rd b/man/diff_time.Rd index d99e284f..99613ef7 100644 --- a/man/diff_time.Rd +++ b/man/diff_time.Rd @@ -89,7 +89,7 @@ specifications into the console for less potential confusion. \section{Time zones}{ Time zones can be passed as either a numeric vector of GMT/UTC offsets (the number of seconds from GMT) or as a character vector. -If the letter, these need to conform with values from \code{\link[base:timezones]{base::OlsonNames()}}. +If the letter, these need to conform with values from \code{\link[base:OlsonNames]{base::OlsonNames()}}. A default timezone can be set with \code{options(mark.default_tz = .)}. The value can either be a numeric diff --git a/man/file_copy_md5.Rd b/man/file_copy_md5.Rd index f1767865..0ea48350 100644 --- a/man/file_copy_md5.Rd +++ b/man/file_copy_md5.Rd @@ -12,7 +12,7 @@ file_copy_md5(path, new_path, overwrite = NA, quiet = FALSE) \item{new_path}{A character vector of paths to the new locations.} \item{overwrite}{When \code{NA}, only saves if the md5 hashes do not match. -Otherwise, see \code{\link[fs:copy]{fs::file_copy()}}.} +Otherwise, see \code{\link[fs:file_copy]{fs::file_copy()}}.} \item{quiet}{When \code{TRUE}, suppresses messages from md5 checks.} } diff --git a/man/fizzbuzz.Rd b/man/fizzbuzz.Rd index 60f9da16..0361019b 100644 --- a/man/fizzbuzz.Rd +++ b/man/fizzbuzz.Rd @@ -1,14 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fizzbuzz.R -\docType{data} \name{fizzbuzz} \alias{fizzbuzz} \alias{fizzbuzz_lazy} \alias{.fizzbuzz_vector} \title{Fizz Buzz} -\format{ -An object of class \code{character} of length 1000000. -} \usage{ fizzbuzz(n, show_numbers = TRUE) @@ -47,4 +43,3 @@ if (package_available("bench")) { } } } -\keyword{datasets} diff --git a/man/is_dir.Rd b/man/is_dir.Rd index 7dc40ff2..27573da8 100644 --- a/man/is_dir.Rd +++ b/man/is_dir.Rd @@ -19,6 +19,6 @@ A \code{logical} vector Is the path a file/directory? } \details{ -These are essentially taken from \code{\link[utils:filetest]{utils::file_test()}} for \code{op = '-d'} and +These are essentially taken from \code{\link[utils:file_test]{utils::file_test()}} for \code{op = '-d'} and \code{op = -f} but separated. } diff --git a/man/logic_ext.Rd b/man/logic_ext.Rd index 707d434a..8bdd46c1 100644 --- a/man/logic_ext.Rd +++ b/man/logic_ext.Rd @@ -74,14 +74,14 @@ All functions take logical or logical-like (i.e., \code{1}, \code{0}, or Extensions to the base logical operations to account for \code{NA} values. -\code{\link[base:Logic]{base::isTRUE()}} and \code{\link[base:Logic]{base::isFALSE()}} will only return single length +\code{\link[base:isTRUE]{base::isTRUE()}} and \code{\link[base:isFALSE]{base::isFALSE()}} will only return single length \code{TRUE} or \code{FALSE} as it checks for valid lengths in the evaluation. When needing to check over a vector for the presence of \code{TRUE} or \code{FALSE} and not being held back by \code{NA} values, \code{\link[=is_true]{is_true()}} and \code{\link[=is_false]{is_false()}} will always provide a \code{TRUE} \code{FALSE} when the vector is logical or return \code{NA} is the vector \code{x} is not logical. -\link{\%xor\%} is just a wrapper for \code{\link[base:Logic]{base::xor()}} +\link{\%xor\%} is just a wrapper for \code{\link[base:xor]{base::xor()}} } \details{ Logical operations, extended diff --git a/man/mark.Rd b/man/mark.Rd index f3f77b45..48ee7050 100644 --- a/man/mark.Rd +++ b/man/mark.Rd @@ -21,4 +21,9 @@ Useful links: \author{ \strong{Maintainer}: Jordan Mark Barbone \email{jmbarbone@gmail.com} (\href{https://orcid.org/0000-0001-9788-3628}{ORCID}) [copyright holder] +Authors: +\itemize{ + \item Jordan Mark Barbone \email{jmbarbone@gmail.com} (\href{https://orcid.org/0000-0001-9788-3628}{ORCID}) [copyright holder] +} + } diff --git a/man/median2.Rd b/man/median2.Rd index 90ebddfb..d722c8a8 100644 --- a/man/median2.Rd +++ b/man/median2.Rd @@ -18,7 +18,7 @@ q50(x, type = 7, na.rm = FALSE) \item{type}{an integer between 1 and 9 selecting one of the nine quantile algorithms detailed below to be used.} -\item{na.rm}{logical; if true, any \code{\link{NA}} and \code{NaN}'s +\item{na.rm}{logical; if true, any \code{\link{NA}} and \code{NaN} values are removed from \code{x} before the quantiles are computed.} } \value{ diff --git a/man/multi_grepl.Rd b/man/multi_grepl.Rd index e8673d73..dbc47f81 100644 --- a/man/multi_grepl.Rd +++ b/man/multi_grepl.Rd @@ -10,13 +10,13 @@ multi_grepl(x, patterns, ..., simplify = TRUE) multi_grep(x, patterns, ..., simplify = TRUE) } \arguments{ -\item{x}{Passed to \code{\link[base:grep]{base::grepl()}}} +\item{x}{Passed to \code{\link[base:grepl]{base::grepl()}}} \item{patterns}{A list or vector of patterns to search across \code{x}; if named value returned will be the name of the pattern -- otherwise the position. Pattern match reported will be the first in the list that is found} -\item{...}{Additional arguments passed to \code{\link[base:grep]{base::grepl()}}} +\item{...}{Additional arguments passed to \code{\link[base:grepl]{base::grepl()}}} \item{simplify}{if \code{FALSE} will return a list of all matches, otherwise the first match found} diff --git a/man/not_available.Rd b/man/not_available.Rd index f53ff6bf..04f16e57 100644 --- a/man/not_available.Rd +++ b/man/not_available.Rd @@ -1,6 +1,5 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/not-available.R -\docType{data} \name{not_available} \alias{not_available} \alias{set_not_available} @@ -8,13 +7,6 @@ \alias{NA_POSIXct_} \alias{NA_POSIXlt_} \title{Make not available} -\format{ -An object of class \code{Date} of length 1. - -An object of class \code{POSIXct} (inherits from \code{POSIXt}) of length 1. - -An object of class \code{logical} of length 1. -} \usage{ not_available(type = "logical", length = 0L) @@ -48,4 +40,3 @@ x class(x) } -\keyword{datasets} diff --git a/man/package_available.Rd b/man/package_available.Rd index 08243da1..485ba33a 100644 --- a/man/package_available.Rd +++ b/man/package_available.Rd @@ -16,5 +16,5 @@ package_available(namespace) } } \description{ -A wrapped \code{\link[base:ns-load]{base::requireNamespace()}} +A wrapped \code{\link[base:requireNamespace]{base::requireNamespace()}} } diff --git a/man/pseudo_id.Rd b/man/pseudo_id.Rd new file mode 100644 index 00000000..fdb0193f --- /dev/null +++ b/man/pseudo_id.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pseudo-id.R +\name{pseudo_id} +\alias{pseudo_id} +\alias{pseudo_id.pseudo_id} +\alias{pseudo_id.default} +\alias{pseudo_id.factor} +\title{Create an ID for a vector} +\usage{ +pseudo_id(x, ...) + +\method{pseudo_id}{pseudo_id}(x, ...) + +\method{pseudo_id}{default}(x, na_last = TRUE, ...) + +\method{pseudo_id}{factor}(x, ...) +} +\arguments{ +\item{x}{A vector of values} + +\item{...}{Additional arguments passed to methods} + +\item{na_last}{\code{Logical} if \code{FALSE} will not place \code{NA} at the end} +} +\value{ +A \code{pseudo_id} object where the \code{integer} value of the vector +correspond to the position of the unique values in the attribute \code{"uniques"}. +} +\description{ +Transforms a vector into an integer of IDs. +} +\examples{ +set.seed(42) +(x <- sample(letters, 10, TRUE)) +(pid <- pseudo_id(x)) +attr(pid, "uniques")[pid] + +} diff --git a/man/range2.Rd b/man/range2.Rd index 49060112..e4d27f56 100644 --- a/man/range2.Rd +++ b/man/range2.Rd @@ -7,7 +7,7 @@ range2(x, na.rm = FALSE) } \arguments{ -\item{x}{A numeric (or character) vector (see Note in \link[base:Extremes]{base::min})} +\item{x}{A numeric (or character) vector (see Note in \link[base:min]{base::min})} \item{na.rm}{Logical, if \code{TRUE} removes missing values} } @@ -16,7 +16,7 @@ A \code{numeric} vector of length 2 of the minimum and maximum values, respectively } \description{ -Employs \code{\link[base:Extremes]{base::min()}} and \code{\link[base:Extremes]{base::max()}}. However, \code{\link[base:range]{base::range()}}, there is +Employs \code{\link[base:min]{base::min()}} and \code{\link[base:max]{base::max()}}. However, \code{\link[base:range]{base::range()}}, there is no argument for removing \code{Inf} values. } \examples{ diff --git a/man/row_bind.Rd b/man/row_bind.Rd index 37c36bcd..1c073a95 100644 --- a/man/row_bind.Rd +++ b/man/row_bind.Rd @@ -18,5 +18,5 @@ and \code{0} rows is returned if \code{...} has no length Bind a list of \code{data.frames} } \seealso{ -\code{\link[dplyr:bind_rows]{dplyr::bind_rows()}} \code{\link[base:cbind]{base::rbind()}} +\code{\link[dplyr:bind_rows]{dplyr::bind_rows()}} \code{\link[base:rbind]{base::rbind()}} } diff --git a/man/sourcing.Rd b/man/sourcing.Rd index bce399b6..adbb1cf3 100644 --- a/man/sourcing.Rd +++ b/man/sourcing.Rd @@ -18,7 +18,7 @@ try_ksource(file, ...) \item{...}{Additional arguments passed to \code{\link[base:source]{base::source()}}} -\item{quiet}{Logical; Determines whether to apply silence to \code{\link[knitr:knit]{knitr::purl()}}} +\item{quiet}{Logical; Determines whether to apply silence to \code{\link[knitr:purl]{knitr::purl()}}} \item{cd}{Logical; if \code{TRUE}, the \strong{R} working directory is temporarily changed to the directory containing file for evaluating} diff --git a/man/switch-ext.Rd b/man/switch-ext.Rd index 5a9e182a..191f42dd 100644 --- a/man/switch-ext.Rd +++ b/man/switch-ext.Rd @@ -22,7 +22,7 @@ switch_case(..., .default = NULL, .envir = parent.frame()) (default: \code{NULL} produces an \code{NA} value derived from \code{...})} \item{.envir}{The environment in which to evaluate the LHS of \code{...} (default: -\code{\link[base:sys.parent]{base::parent.frame()}})} +\code{\link[base:parent.frame]{base::parent.frame()}})} } \value{ A named vector of values of same length \code{x}; or for diff --git a/man/tableNA.Rd b/man/tableNA.Rd index 6eff10de..2d84e7f3 100644 --- a/man/tableNA.Rd +++ b/man/tableNA.Rd @@ -49,9 +49,10 @@ tableNA(x[1], x[2]) tableNA(x[1], x[2], x[3]) # equivalent ot tableNA(x, .list = TRUE) } \references{ -Becker, R. A., Chambers, J. M. and Wilks, A. R. (1988) - \emph{The New S Language}. - Wadsworth & Brooks/Cole. +{\if{html}{\out{}}Becker RA, Chambers JM, Wilks AR (1988). +\emph{The New S Language}. +Chapman and Hall/CRC, London. +ISBN 053409192X.} } \seealso{ \code{\link[base]{tabulate}} is the underlying function and allows finer diff --git a/man/vap.Rd b/man/vap.Rd index 3b6ffaad..14676bfa 100644 --- a/man/vap.Rd +++ b/man/vap.Rd @@ -39,7 +39,7 @@ A vector of type matching the intended value in the function name. Wrappers for vapply } \details{ -These are simply wrappers for \code{\link[base:lapply]{base::vapply()}} to shorten lines. +These are simply wrappers for \code{\link[base:vapply]{base::vapply()}} to shorten lines. Each function is designed to use specific vector types: @@ -53,5 +53,5 @@ Each function is designed to use specific vector types: } } \seealso{ -\code{\link[base:lapply]{base::vapply()}} +\code{\link[base:vapply]{base::vapply()}} } diff --git a/man/write_file_md5.Rd b/man/write_file_md5.Rd index c4230055..6bcc56fe 100644 --- a/man/write_file_md5.Rd +++ b/man/write_file_md5.Rd @@ -31,7 +31,7 @@ determined by file extension of \code{path}, if present, otherwise by the type of object of \code{x}.} \item{overwrite}{When \code{NA}, only saves if the md5 hashes do not match. -Otherwise, see \code{\link[fs:copy]{fs::file_copy()}}.} +Otherwise, see \code{\link[fs:file_copy]{fs::file_copy()}}.} \item{quiet}{When \code{TRUE}, suppresses messages from md5 checks.} @@ -44,7 +44,7 @@ Otherwise, see \code{\link[fs:copy]{fs::file_copy()}}.} \value{ \itemize{ \item \code{\link[=write_file_md5]{write_file_md5()}}: \code{x}, invisibly. When \code{path} is not the -\code{\link[base:showConnections]{base::stdout()}}, \code{x} is returned with the attribute \code{"path"} set to the +\code{\link[base:stdout]{base::stdout()}}, \code{x} is returned with the attribute \code{"path"} set to the result of \code{\link[=file_copy_md5]{file_copy_md5()}}. \item \code{\link[=mark_write_methods]{mark_write_methods()}}: A list of applicable methods and their aliases From ebf9c4a41f0916973cef31ed79462c424c066e86 Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sat, 20 Jun 2026 10:49:11 -0400 Subject: [PATCH 24/25] some updates (#91) --- DESCRIPTION | 2 + R/char2fact.R | 2 +- R/fact.R | 21 ++++-- R/pseudo-id.R | 5 ++ R/rexports-facts.R | 3 + man/fact.Rd | 101 +++++++++++++++++++++++++++++ man/print.pseudo_id.Rd | 25 +++++++ tests/testthat/_snaps/write.new.md | 22 +++++++ 8 files changed, 174 insertions(+), 7 deletions(-) create mode 100644 R/rexports-facts.R create mode 100644 man/fact.Rd create mode 100644 man/print.pseudo_id.Rd create mode 100644 tests/testthat/_snaps/write.new.md diff --git a/DESCRIPTION b/DESCRIPTION index b40d6c18..68353bf7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,6 +24,7 @@ Depends: Imports: cli, cnd, + facts, fs (>= 0.2.0), fuj, generics, @@ -59,6 +60,7 @@ Suggests: xopen, yaml (>= 2.3.9), Remotes: + github::jmbarbone/facts@simplify, github::jmbarbone/cnd@v0.1.1.9002, github::jmbarbone/fuj@v0.2.2.9011 Roxygen: list(markdown = TRUE) diff --git a/R/char2fact.R b/R/char2fact.R index d85049da..54533fbc 100644 --- a/R/char2fact.R +++ b/R/char2fact.R @@ -20,7 +20,7 @@ char2fact.default <- function(x, n = 5) { #' @rdname char2fact #' @export char2fact.character <- function(x, n = 5) { - id <- pseudo_id(x) + fct <- factor(x) if (length(attr(id, "values")) <= n) { x <- fact(id) diff --git a/R/fact.R b/R/fact.R index d6497b46..05af7aa3 100644 --- a/R/fact.R +++ b/R/fact.R @@ -157,6 +157,7 @@ converter <- function(x) { #' @name fact `converter<-` <- function(x, value) { attr(x, "converter") <- match.fun(value) + x } #' @export @@ -172,6 +173,7 @@ is.fact <- is_fact # nolint: object_name_linter. # helpers ----------------------------------------------------------------- new_fact <- function(x, levels, fun) { + x <- as.integer(x) levels(x) <- as.character(levels) converter(x) <- fun # assign "factor" class _after_ levels() @@ -218,16 +220,23 @@ as.ordered.fact <- function(x) { if (is.ordered(x)) { return(x) } - v <- values(x) - class(x) <- c("ordered", class(x)) - values(x) <- v + + x <- fact(x) + lev <- levels(x) + if (anyNA(levels(x))) { + # NA values just need to be shifted + m <- which(is.na(lev)) + x <- as.integer(x) + x[x == m] <- NA_integer_ + x <- x - (x > m) + levels(x) <- lev[-m] + } + class(x) <- c("ordered", "fact", "factor") x } #' @export -as.factor.fact <- function(x) { - struct(x, c(if (is.ordered(x)) "ordered", "factor"), levels = levels(x)) -} +as.factor.fact <- identity #' @export print.fact <- function( diff --git a/R/pseudo-id.R b/R/pseudo-id.R index c1f4e40c..de976387 100644 --- a/R/pseudo-id.R +++ b/R/pseudo-id.R @@ -16,6 +16,11 @@ #' #' @export pseudo_id <- function(x, ...) { + # TODO consider deprecating pseudo_id() in v0.9.0 + # warning(deprecated_warning( + # "pseudo_id() is deprecated and will be removed in a future version.", + # " Use as.integer(fact(x)) instead." + # )) UseMethod("pseudo_id", x) } diff --git a/R/rexports-facts.R b/R/rexports-facts.R new file mode 100644 index 00000000..f9d9417f --- /dev/null +++ b/R/rexports-facts.R @@ -0,0 +1,3 @@ +#' @importFrom facts fact +#' @export +facts::fact diff --git a/man/fact.Rd b/man/fact.Rd new file mode 100644 index 00000000..3ad020fb --- /dev/null +++ b/man/fact.Rd @@ -0,0 +1,101 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fact.R +\name{fact} +\alias{fact} +\alias{fact.default} +\alias{fact.character} +\alias{fact.numeric} +\alias{fact.integer} +\alias{fact.Date} +\alias{fact.POSIXct} +\alias{fact.POSIXlt} +\alias{fact.logical} +\alias{fact.factor} +\alias{fact.fact} +\alias{as_values} +\alias{as.values} +\alias{values} +\alias{converter} +\alias{converter<-} +\alias{is_fact} +\alias{is.fact} +\title{Factor} +\usage{ +fact(x) + +\method{fact}{default}(x) + +\method{fact}{character}(x) + +\method{fact}{numeric}(x) + +\method{fact}{integer}(x) + +\method{fact}{Date}(x) + +\method{fact}{POSIXct}(x) + +\method{fact}{POSIXlt}(x) + +\method{fact}{logical}(x) + +\method{fact}{factor}(x) + +\method{fact}{fact}(x) + +as_values(x) + +as.values(x) + +values(x) + +converter(x) + +converter(x) <- value + +is_fact(x) + +is.fact(x) +} +\arguments{ +\item{x}{A vector of values} +} +\value{ +A vector of equal length of \code{x} with class \code{fact} and \code{factor}. If +\code{x} was \code{ordered}, that class is added in between. +} +\description{ +Quickly create a factor +} +\details{ +\code{\link[=fact]{fact()}} can be about 5 times quicker than \code{\link[base:factor]{base::factor()}} or +\code{\link[base:as.factor]{base::as.factor()}} as it doesn't bother sorting the levels for non-numeric +data or have other checks or features. It simply converts a vector to a +factor with all unique values as levels with \code{NA}s included. + +\code{\link[=fact.factor]{fact.factor()}} will perform several checks on a factor to include +\code{NA} levels and to check if the levels should be reordered to conform with +the other methods. The \code{\link[=fact.fact]{fact.fact()}} method simple returns \code{x}. +} +\section{level orders}{ + + +The order of the levels may be adjusted to these rules depending on the +class of \code{x}: +\describe{ +\item{\code{character}}{The order of appearance} +\item{\code{numeric}/\code{integer}/\code{Date}/\code{POSIXt}}{By the numeric order} +\item{\code{logical}}{As \code{TRUE}, \code{FALSE}, then \code{NA} if present} +\item{\code{factor}}{Numeric if levels can be safely converted, otherwise as +they are} +} +} + +\seealso{ +\code{\link[=as_ordered]{as_ordered()}} + +Other factors: +\code{\link[=char2fact]{char2fact()}}, +\code{\link[=fact2char]{fact2char()}} +} +\concept{factors} diff --git a/man/print.pseudo_id.Rd b/man/print.pseudo_id.Rd new file mode 100644 index 00000000..c88d6df6 --- /dev/null +++ b/man/print.pseudo_id.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pseudo-id.R +\name{print.pseudo_id} +\alias{print.pseudo_id} +\title{Print \code{pseudo_id}} +\usage{ +\method{print}{pseudo_id}(x, ..., all = FALSE) +} +\arguments{ +\item{x}{An object of class \code{pseudo_id}} + +\item{...}{Not implemented} + +\item{all}{if \code{TRUE} will print all uniques. This is not recommend for many +uniques as it will crowd the console output} +} +\value{ +\code{x}, invisibly. Called for its side effects. +} +\description{ +Print \code{pseudo_id} +} +\seealso{ +\code{\link[=pseudo_id]{pseudo_id()}} +} diff --git a/tests/testthat/_snaps/write.new.md b/tests/testthat/_snaps/write.new.md new file mode 100644 index 00000000..eb791f28 --- /dev/null +++ b/tests/testthat/_snaps/write.new.md @@ -0,0 +1,22 @@ +# arrow prints something to stdout() + + Code + write_file_md5(dataframe(a = 1), method = "feather") + Output + Table + 1 rows x 1 columns + $a + +--- + + Code + write_file_md5(dataframe(a = 1), method = "parquet") + Output + # A data frame: 2 x 14 + file_name r_col name r_type type type_length repetition_type converted_type + + 1 /tmp/Rtmp~ NA sche~ NA + 2 /tmp/Rtmp~ 1 a double DOUB~ NA REQUIRED + # i 6 more variables: logical_type >, num_children , scale , + # precision , field_id , children + From 9cf5cc950c7913066420e2c844f82f7dd2900042 Mon Sep 17 00:00:00 2001 From: Jordan Mark Barbone Date: Sat, 20 Jun 2026 11:27:05 -0400 Subject: [PATCH 25/25] some updates (#91) --- DESCRIPTION | 6 +- NAMESPACE | 25 +- R/char2fact.R | 2 +- R/counts.R | 2 +- R/fact.R | 298 ---------------------- R/pseudo-id.R | 2 +- R/unlist.R | 2 +- man/char2fact.Rd | 1 - man/fact.Rd | 101 -------- man/fact2char.Rd | 3 +- man/reexports.Rd | 11 +- tests/testthat/_snaps/fact.md | 55 ---- tests/testthat/_snaps/write.md | 14 +- tests/testthat/_snaps/write.new.md | 22 -- tests/testthat/test-counts.R | 5 +- tests/testthat/test-fact.R | 391 ----------------------------- 16 files changed, 22 insertions(+), 918 deletions(-) delete mode 100644 R/fact.R delete mode 100644 man/fact.Rd delete mode 100644 tests/testthat/_snaps/fact.md delete mode 100644 tests/testthat/_snaps/write.new.md delete mode 100644 tests/testthat/test-fact.R diff --git a/DESCRIPTION b/DESCRIPTION index 68353bf7..2b12a1b2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -60,9 +60,9 @@ Suggests: xopen, yaml (>= 2.3.9), Remotes: - github::jmbarbone/facts@simplify, + github::jmbarbone/facts, github::jmbarbone/cnd@v0.1.1.9002, - github::jmbarbone/fuj@v0.2.2.9011 + github::jmbarbone/fuj@105-defaults Roxygen: list(markdown = TRUE) Config/testthat/edition: 3 Config/testthat/parallel: true @@ -89,7 +89,6 @@ Collate: 'directory.R' 'environments.R' 'expand.R' - 'fact.R' 'fct-expand-seq.R' 'file.R' 'fizzbuzz.R' @@ -125,6 +124,7 @@ Collate: 'recode.R' 'reexports-fuj.R' 'reexports-magrittr.R' + 'rexports-facts.R' 'round-by.R' 'round.R' 'row-bind.R' diff --git a/NAMESPACE b/NAMESPACE index cabf03ae..238b9ed8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,8 +3,6 @@ S3method(append0,data.frame) S3method(append0,default) S3method(append0,list) -S3method(as.factor,fact) -S3method(as.ordered,fact) S3method(assign_labels,data.frame) S3method(assign_labels,default) S3method(char2fact,character) @@ -19,16 +17,6 @@ S3method(depth,default) S3method(depth,list) S3method(detail,data.frame) S3method(detail,default) -S3method(fact,Date) -S3method(fact,POSIXct) -S3method(fact,POSIXlt) -S3method(fact,character) -S3method(fact,default) -S3method(fact,fact) -S3method(fact,factor) -S3method(fact,integer) -S3method(fact,logical) -S3method(fact,numeric) S3method(get_labels,data.frame) S3method(get_labels,default) S3method(is_false,default) @@ -38,7 +26,6 @@ S3method(is_true,logical) S3method(normalize,data.frame) S3method(normalize,default) S3method(print,diff_time) -S3method(print,fact) S3method(print,has_catch) S3method(print,mark_bib_df) S3method(print,mark_bib_entry) @@ -79,7 +66,6 @@ export("%out%") export("%wi%") export("%wo%") export("%xor%") -export("converter<-") export("note<-") export(.fizzbuzz_vector) export(AND) @@ -95,10 +81,6 @@ export(add_file_timestamp) export(any_match) export(are_identical) export(array_extract) -export(as.factor) -export(as.ordered) -export(as.values) -export(as_values) export(assign_labels) export(base_alpha) export(base_n) @@ -110,7 +92,6 @@ export(checkOptions) export(chr_split) export(collapse0) export(complete_cases) -export(converter) export(counts) export(date_from_partial) export(depth) @@ -157,13 +138,11 @@ export(has_message) export(has_warning) export(import) export(insert) -export(is.fact) export(isNA) export(is_blank) export(is_blank_cols) export(is_boolean) export(is_dir) -export(is_fact) export(is_false) export(is_file) export(is_linux) @@ -276,7 +255,6 @@ export(unlist0) export(update_version) export(use_author) export(user_file) -export(values) export(vap_chr) export(vap_cplx) export(vap_date) @@ -300,6 +278,7 @@ importFrom(cnd,input_error) importFrom(cnd,input_warning) importFrom(cnd,type_error) importFrom(cnd,value_error) +importFrom(facts,fact) importFrom(fuj,"%::%") importFrom(fuj,"%:::%") importFrom(fuj,"%colons%") @@ -325,6 +304,4 @@ importFrom(fuj,require_namespace) importFrom(fuj,set_names) importFrom(fuj,struct) importFrom(fuj,wuffle) -importFrom(generics,as.factor) -importFrom(generics,as.ordered) importFrom(magrittr,"%>%") diff --git a/R/char2fact.R b/R/char2fact.R index 54533fbc..e1b1d89b 100644 --- a/R/char2fact.R +++ b/R/char2fact.R @@ -22,7 +22,7 @@ char2fact.default <- function(x, n = 5) { char2fact.character <- function(x, n = 5) { fct <- factor(x) - if (length(attr(id, "values")) <= n) { + if (length(attr(id, "uniques")) <= n) { x <- fact(id) } diff --git a/R/counts.R b/R/counts.R index 33f358bd..4100e411 100644 --- a/R/counts.R +++ b/R/counts.R @@ -49,7 +49,7 @@ counts <- function(x, ...) { #' @export counts.default <- function(x, sort = FALSE, ...) { x <- pseudo_id(x) - u <- attr(x, "values") + u <- attr(x, "uniques") out <- tabulate(x, length(u)) nas <- is.na(u) names(out) <- c(u[!nas], u[nas]) diff --git a/R/fact.R b/R/fact.R deleted file mode 100644 index 05af7aa3..00000000 --- a/R/fact.R +++ /dev/null @@ -1,298 +0,0 @@ -# NOTE: I'll need to document this separately. Something about changing the -# scope so it's very limited - -# NOTE I'll eventually replace these with jmbarbone/facts (or jmbarbone/fctrs) - -# fact -------------------------------------------------------------------- - -#' Factor -#' -#' Quickly create a factor -#' -#' @details [mark::fact()] can be about 5 times quicker than [base::factor()] or -#' [base::as.factor()] as it doesn't bother sorting the levels for non-numeric -#' data or have other checks or features. It simply converts a vector to a -#' factor with all unique values as levels with `NA`s included. -#' -#' [mark::fact.factor()] will perform several checks on a factor to include -#' `NA` levels and to check if the levels should be reordered to conform with -#' the other methods. The [mark::fact.fact()] method simple returns `x`. -#' -#' @section level orders: -#' -#' The order of the levels may be adjusted to these rules depending on the -#' class of `x`: -#' \describe{ -#' \item{`character`}{The order of appearance} -#' \item{`numeric`/`integer`/`Date`/`POSIXt`}{By the numeric order} -#' \item{`logical`}{As `TRUE`, `FALSE`, then `NA` if present} -#' \item{`factor`}{Numeric if levels can be safely converted, otherwise as -#' they are} -#' } -#' -#' @param x A vector of values -#' @return A vector of equal length of `x` with class `fact` and `factor`. If -#' `x` was `ordered`, that class is added in between. -#' -#' @seealso [mark::as_ordered()] -#' @family factors -#' @export -fact <- function(x) { - UseMethod("fact", x) -} - -#' @rdname fact -#' @export -fact.default <- function(x) { - stop(class_error(x = x, "there is no fact method for this class")) -} - -#' @rdname fact -#' @export -fact.character <- function(x) { - u <- unique(x) - if (anyNA(u)) { - m <- match(NA, u) - if (move_na_last()) { - u <- c(u[-m], NA) - } else { - u <- c(NA, u[-m]) - } - } - new_fact(match(x, u), u, identity) -} - -#' @rdname fact -#' @export -fact.numeric <- function(x) { - fact_numeric(x, as.numeric) -} - -#' @rdname fact -#' @export -fact.integer <- function(x) { - fact_numeric(x, as.integer) -} - -#' @rdname fact -#' @export -fact.Date <- function(x) { - fact_numeric(x, as.Date) -} - -#' @rdname fact -#' @export -fact.POSIXct <- function(x) { - fact_numeric(x, as.POSIXct) -} - -#' @rdname fact -#' @export -fact.POSIXlt <- function(x) { - fact_numeric(x, as.POSIXlt) -} - -#' @rdname fact -#' @export -fact.logical <- function(x) { - u <- if (move_na_last()) c(FALSE, TRUE, NA) else c(NA, FALSE, TRUE) - u <- u[u %in% x] - new_fact(match(x, u), u, as.logical) -} - -#' @rdname fact -#' @export -fact.factor <- function(x) { - old <- levels(x) - old <- utils::type.convert(old, as.is = TRUE, tryLogical = FALSE) - if (is.character(old)) { - maybe <- as.POSIXlt(x, optional = TRUE) - if (!all(is.na(maybe))) { - old <- maybe - } - } - o <- order(old, na.last = move_na_last()) - new <- old[o] - x <- match(old, new)[x] - for (c in class(old)) { - fun <- get0(sprintf("as.%s", c)) - if (!is.null(fun)) { - break - } - } - new_fact(x, new, fun %||% identity) -} - -#' @rdname fact -#' @export -fact.fact <- function(x) { - x -} - -# others ------------------------------------------------------------------ - -#' @export -#' @name fact -as_values <- function(x) { - values(x)[x] -} - -#' @export -#' @name fact -as.values <- as_values # nolint: object_name_linter. - -#' @export -#' @name fact -values <- function(x) { - converter(x)(levels(x)) -} - -#' @export -#' @name fact -converter <- function(x) { - exattr(x, "converter") -} - -#' @export -#' @name fact -`converter<-` <- function(x, value) { - attr(x, "converter") <- match.fun(value) - x -} - -#' @export -#' @name fact -is_fact <- function(x) { - inherits(x, "fact") -} - -#' @export -#' @name fact -is.fact <- is_fact # nolint: object_name_linter. - -# helpers ----------------------------------------------------------------- - -new_fact <- function(x, levels, fun) { - x <- as.integer(x) - levels(x) <- as.character(levels) - converter(x) <- fun - # assign "factor" class _after_ levels() - class(x) <- c("fact", "factor") - x -} - - -fact_numeric <- function(x, converter) { - u <- unique(x) - u <- u[order(u, method = "radix", na.last = move_na_last())] - l <- as.character(u) - d <- !duplicated(l) - u <- u[d] - l <- l[d] - new_fact(match(x, u), l, converter) -} - - -move_na_last <- function() { - switch( - as.character(getOption("mark.fact.na.position", "first")), - first = FALSE, - last = TRUE, - stop(value_error( - "options(mark.fact.na.position) must be 'first' or 'last'" - )) - ) -} - - -# other methods ----------------------------------------------------------- - -#' @importFrom generics as.ordered -#' @export -generics::as.ordered - -#' @importFrom generics as.factor -#' @export -generics::as.factor - -#' @export -as.ordered.fact <- function(x) { - if (is.ordered(x)) { - return(x) - } - - x <- fact(x) - lev <- levels(x) - if (anyNA(levels(x))) { - # NA values just need to be shifted - m <- which(is.na(lev)) - x <- as.integer(x) - x[x == m] <- NA_integer_ - x <- x - (x > m) - levels(x) <- lev[-m] - } - class(x) <- c("ordered", "fact", "factor") - x -} - -#' @export -as.factor.fact <- identity - -#' @export -print.fact <- function( - x, - max_levels = getOption("mark.fact.max_levels", TRUE), - width = getOption("width"), - ... -) { - # mostly a reformatted base::print.factor() - ord <- is.ordered(x) - if (length(x) == 0L) { - cat(if (ord) "ordered" else "factor", "(0)\n", sep = "") - } else { - print(as.character(x), quote = FALSE, ...) - } - - if (max_levels) { - lev <- encodeString(levels(x), quote = "") - n <- length(lev) - colsep <- if (ord) " < " else " " - # instead of "Labels: " - T0 <- "Values: " # nolint: object_name_linter. - if (is.logical(max_levels)) { - max_levels <- { - width <- width - (nchar(T0, "w") + 3L + 1L + 3L) - lenl <- cumsum(nchar(lev, "w") + nchar(colsep, "w")) - - if (n <= 1L || lenl[n] <= width) { - n - } else { - max(1L, which.max(lenl > width) - 1L) - } - } - } - drop <- n > max_levels - cat( - if (drop) paste(format(n), ""), - T0, - paste( - if (drop) { - c(lev[1:max(1L, max_levels - 1L)], "...", if (max_levels > 1L) lev[n]) - } else { - lev - }, - collapse = colsep - ), - "\n", - sep = "" - ) - - # Be nice to haven_labelled - # lab <- exattr(x, "label") - # if (!is.null(lab)) { - # cat("Label: ", paste(format(lab), ""), "\n", sep = "") - # } - } - - invisible(x) -} diff --git a/R/pseudo-id.R b/R/pseudo-id.R index de976387..ae10c9b7 100644 --- a/R/pseudo-id.R +++ b/R/pseudo-id.R @@ -46,7 +46,7 @@ pseudo_id.default <- function(x, na_last = TRUE, ...) { #' @export #' @rdname pseudo_id pseudo_id.factor <- function(x, ...) { - pseudo_id(fact_values(fact(x))) + pseudo_id(facts::values(fact(x))) } #' Print `pseudo_id` diff --git a/R/unlist.R b/R/unlist.R index 3ffac43e..a372001a 100644 --- a/R/unlist.R +++ b/R/unlist.R @@ -46,5 +46,5 @@ squash_vec <- function(x, sep = ".") { id <- pseudo_id(x, na_last = FALSE) nm <- names(x) squasher <- function(i) collapse0(nm[i], sep = sep) - attr(id, "values") %names% vap_chr(split(seq_along(id), id), squasher) + attr(id, "uniques") %names% vap_chr(split(seq_along(id), id), squasher) } diff --git a/man/char2fact.Rd b/man/char2fact.Rd index 69ebe309..d89114cf 100644 --- a/man/char2fact.Rd +++ b/man/char2fact.Rd @@ -30,7 +30,6 @@ Converts characters to factors \code{\link[=fact2char]{fact2char()}} Other factors: -\code{\link[=fact]{fact()}}, \code{\link[=fact2char]{fact2char()}} } \concept{factors} diff --git a/man/fact.Rd b/man/fact.Rd deleted file mode 100644 index 3ad020fb..00000000 --- a/man/fact.Rd +++ /dev/null @@ -1,101 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fact.R -\name{fact} -\alias{fact} -\alias{fact.default} -\alias{fact.character} -\alias{fact.numeric} -\alias{fact.integer} -\alias{fact.Date} -\alias{fact.POSIXct} -\alias{fact.POSIXlt} -\alias{fact.logical} -\alias{fact.factor} -\alias{fact.fact} -\alias{as_values} -\alias{as.values} -\alias{values} -\alias{converter} -\alias{converter<-} -\alias{is_fact} -\alias{is.fact} -\title{Factor} -\usage{ -fact(x) - -\method{fact}{default}(x) - -\method{fact}{character}(x) - -\method{fact}{numeric}(x) - -\method{fact}{integer}(x) - -\method{fact}{Date}(x) - -\method{fact}{POSIXct}(x) - -\method{fact}{POSIXlt}(x) - -\method{fact}{logical}(x) - -\method{fact}{factor}(x) - -\method{fact}{fact}(x) - -as_values(x) - -as.values(x) - -values(x) - -converter(x) - -converter(x) <- value - -is_fact(x) - -is.fact(x) -} -\arguments{ -\item{x}{A vector of values} -} -\value{ -A vector of equal length of \code{x} with class \code{fact} and \code{factor}. If -\code{x} was \code{ordered}, that class is added in between. -} -\description{ -Quickly create a factor -} -\details{ -\code{\link[=fact]{fact()}} can be about 5 times quicker than \code{\link[base:factor]{base::factor()}} or -\code{\link[base:as.factor]{base::as.factor()}} as it doesn't bother sorting the levels for non-numeric -data or have other checks or features. It simply converts a vector to a -factor with all unique values as levels with \code{NA}s included. - -\code{\link[=fact.factor]{fact.factor()}} will perform several checks on a factor to include -\code{NA} levels and to check if the levels should be reordered to conform with -the other methods. The \code{\link[=fact.fact]{fact.fact()}} method simple returns \code{x}. -} -\section{level orders}{ - - -The order of the levels may be adjusted to these rules depending on the -class of \code{x}: -\describe{ -\item{\code{character}}{The order of appearance} -\item{\code{numeric}/\code{integer}/\code{Date}/\code{POSIXt}}{By the numeric order} -\item{\code{logical}}{As \code{TRUE}, \code{FALSE}, then \code{NA} if present} -\item{\code{factor}}{Numeric if levels can be safely converted, otherwise as -they are} -} -} - -\seealso{ -\code{\link[=as_ordered]{as_ordered()}} - -Other factors: -\code{\link[=char2fact]{char2fact()}}, -\code{\link[=fact2char]{fact2char()}} -} -\concept{factors} diff --git a/man/fact2char.Rd b/man/fact2char.Rd index 9e6cb7ea..c1d3c73a 100644 --- a/man/fact2char.Rd +++ b/man/fact2char.Rd @@ -22,7 +22,6 @@ Convert factor columns to characters in a \code{data.frame} \code{\link[=char2fact]{char2fact()}} Other factors: -\code{\link[=char2fact]{char2fact()}}, -\code{\link[=fact]{fact()}} +\code{\link[=char2fact]{char2fact()}} } \concept{factors} diff --git a/man/reexports.Rd b/man/reexports.Rd index 5cb7e9f4..16f1f359 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -1,11 +1,9 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fact.R, R/reexports-fuj.R, -% R/reexports-magrittr.R +% Please edit documentation in R/reexports-fuj.R, R/reexports-magrittr.R, +% R/rexports-facts.R \docType{import} \name{reexports} \alias{reexports} -\alias{as.ordered} -\alias{as.factor} \alias{\%||\%} \alias{\%:::\%} \alias{\%::\%} @@ -32,6 +30,7 @@ \alias{require_namespace} \alias{struct} \alias{\%>\%} +\alias{fact} \title{Objects exported from other packages} \keyword{internal} \description{ @@ -39,9 +38,9 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ - \item{fuj}{\code{\link[fuj:\%::\%]{\%::\%}}, \code{\link[fuj:\%:::\%]{\%:::\%}}, \code{\link[fuj:\%colons\%]{\%colons\%}}, \code{\link[fuj:\%len\%]{\%len\%}}, \code{\link[fuj:\%names\%]{\%names\%}}, \code{\link[fuj:\%out\%]{\%out\%}}, \code{\link[fuj:\%wi\%]{\%wi\%}}, \code{\link[fuj:\%wo\%]{\%wo\%}}, \code{\link[fuj:\%||\%]{\%||\%}}, \code{\link[fuj:any_match]{any_match()}}, \code{\link[fuj:exattr]{exattr()}}, \code{\link[fuj:flip]{flip()}}, \code{\link[fuj:is_linux]{is_linux()}}, \code{\link[fuj:is_macos]{is_macos()}}, \code{\link[fuj:is_named]{is_named()}}, \code{\link[fuj:is_windows]{is_windows()}}, \code{\link[fuj:muffle]{muffle()}}, \code{\link[fuj:no_match]{no_match()}}, \code{\link[fuj:quick_df]{quick_df()}}, \code{\link[fuj:quick_dfl]{quick_dfl()}}, \code{\link[fuj:remove_names]{remove_names()}}, \code{\link[fuj:require_namespace]{require_namespace()}}, \code{\link[fuj:set_names]{set_names()}}, \code{\link[fuj:struct]{struct()}}, \code{\link[fuj:wuffle]{wuffle()}}} + \item{facts}{\code{\link[facts:fact]{fact()}}} - \item{generics}{\code{\link[generics:as.factor]{as.factor()}}, \code{\link[generics:as.ordered]{as.ordered()}}} + \item{fuj}{\code{\link[fuj:\%::\%]{\%::\%}}, \code{\link[fuj:\%:::\%]{\%:::\%}}, \code{\link[fuj:\%colons\%]{\%colons\%}}, \code{\link[fuj:\%len\%]{\%len\%}}, \code{\link[fuj:\%names\%]{\%names\%}}, \code{\link[fuj:\%out\%]{\%out\%}}, \code{\link[fuj:\%wi\%]{\%wi\%}}, \code{\link[fuj:\%wo\%]{\%wo\%}}, \code{\link[fuj:\%||\%]{\%||\%}}, \code{\link[fuj:any_match]{any_match()}}, \code{\link[fuj:exattr]{exattr()}}, \code{\link[fuj:flip]{flip()}}, \code{\link[fuj:is_linux]{is_linux()}}, \code{\link[fuj:is_macos]{is_macos()}}, \code{\link[fuj:is_named]{is_named()}}, \code{\link[fuj:is_windows]{is_windows()}}, \code{\link[fuj:muffle]{muffle()}}, \code{\link[fuj:no_match]{no_match()}}, \code{\link[fuj:quick_df]{quick_df()}}, \code{\link[fuj:quick_dfl]{quick_dfl()}}, \code{\link[fuj:remove_names]{remove_names()}}, \code{\link[fuj:require_namespace]{require_namespace()}}, \code{\link[fuj:set_names]{set_names()}}, \code{\link[fuj:struct]{struct()}}, \code{\link[fuj:wuffle]{wuffle()}}} \item{magrittr}{\code{\link[magrittr:\%>\%]{\%>\%}}} }} diff --git a/tests/testthat/_snaps/fact.md b/tests/testthat/_snaps/fact.md deleted file mode 100644 index cb5c9a9f..00000000 --- a/tests/testthat/_snaps/fact.md +++ /dev/null @@ -1,55 +0,0 @@ -# snapshots - - Code - fact(character()) - Output - factor(0) - Levels: - ---- - - Code - fact(1:5) - Output - [1] 1 2 3 4 5 - Levels: 1 2 3 4 5 - ---- - - Code - print(fact(1:100), max_levels = TRUE) - Output - [1] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 - [19] 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 - [37] 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 - [55] 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 - [73] 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 - [91] 91 92 93 94 95 96 97 98 99 100 - 100 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 ... 100 - ---- - - Code - print(fact(1:100), max_levels = 20) - Output - [1] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 - [19] 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 - [37] 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 - [55] 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 - [73] 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 - [91] 91 92 93 94 95 96 97 98 99 100 - 100 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ... 100 - ---- - - Code - print(fact(1:100), max_levels = 100) - Output - [1] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 - [19] 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 - [37] 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 - [55] 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 - [73] 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 - [91] 91 92 93 94 95 96 97 98 99 100 - Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 - diff --git a/tests/testthat/_snaps/write.md b/tests/testthat/_snaps/write.md index 6b3add41..eb791f28 100644 --- a/tests/testthat/_snaps/write.md +++ b/tests/testthat/_snaps/write.md @@ -12,11 +12,11 @@ Code write_file_md5(dataframe(a = 1), method = "parquet") Output - # A data frame: 2 x 12 - file_name name r_type type type_length repetition_type converted_type - - 1 /tmp/ sche~ NA - 2 /tmp/ a double DOUB~ NA REQUIRED - # i 5 more variables: logical_type >, num_children , scale , - # precision , field_id + # A data frame: 2 x 14 + file_name r_col name r_type type type_length repetition_type converted_type + + 1 /tmp/Rtmp~ NA sche~ NA + 2 /tmp/Rtmp~ 1 a double DOUB~ NA REQUIRED + # i 6 more variables: logical_type >, num_children , scale , + # precision , field_id , children diff --git a/tests/testthat/_snaps/write.new.md b/tests/testthat/_snaps/write.new.md deleted file mode 100644 index eb791f28..00000000 --- a/tests/testthat/_snaps/write.new.md +++ /dev/null @@ -1,22 +0,0 @@ -# arrow prints something to stdout() - - Code - write_file_md5(dataframe(a = 1), method = "feather") - Output - Table - 1 rows x 1 columns - $a - ---- - - Code - write_file_md5(dataframe(a = 1), method = "parquet") - Output - # A data frame: 2 x 14 - file_name r_col name r_type type type_length repetition_type converted_type - - 1 /tmp/Rtmp~ NA sche~ NA - 2 /tmp/Rtmp~ 1 a double DOUB~ NA REQUIRED - # i 6 more variables: logical_type >, num_children , scale , - # precision , field_id , children - diff --git a/tests/testthat/test-counts.R b/tests/testthat/test-counts.R index 83bf6905..a284ca86 100644 --- a/tests/testthat/test-counts.R +++ b/tests/testthat/test-counts.R @@ -1,5 +1,3 @@ - - # counts() ---------------------------------------------------------------- test_that("counts.default() work", { @@ -19,7 +17,6 @@ test_that("counts.default() work", { }) test_that("counts() works with NAs", { - # Correct sort x <- c(FALSE, TRUE, NA) res <- set_names(c(1, 1, 1), x) @@ -123,7 +120,7 @@ test_that("props() handles NA", { df <- dataframe(x = x, y = y) res_x1 <- dataframe(x = c(1, 2, 3, NA), prop = c(.20, .40, .20, .20)) - res_x2 <- dataframe(x = c(1, 2, 3, NA), prop = c(.25, .50, .25, NA)) + res_x2 <- dataframe(x = c(1, 2, 3, NA), prop = c(.25, .50, .25, NA)) expect_identical(props(df, "x"), res_x1) expect_identical(props(df, "x", na.rm = TRUE), res_x2) diff --git a/tests/testthat/test-fact.R b/tests/testthat/test-fact.R deleted file mode 100644 index 4e720445..00000000 --- a/tests/testthat/test-fact.R +++ /dev/null @@ -1,391 +0,0 @@ - -# fact.logical() ---- - -test_that("fact.logical() works", { - x <- fact(c(TRUE, FALSE, NA)) - expect_message(capture.output(print(x)), NA) - - x <- fact(c(FALSE, NA, NA, TRUE, FALSE)) - res <- new_fact(c(2L, 3L, 3L, 1L, 2L), c(TRUE, FALSE, NA)) - expect_identical(x, res) - - expect_false(anyNA(x)) -}) - -# fact.pseudo_id() ---- - -test_that("fact.pseudo_id() works", { - expect_message( - capture.output(print(fact(pseudo_id(c("a", "a", "b", NA_character_))))), - NA - ) - - # Should appropriately order numeric values - x <- c(0L, 10L, 10L, NA, 0L, 5L) - id <- pseudo_id(x) - f <- fact(id) - res <- new_fact(c(1L, 3L, 3L, 4L, 1L, 2L), c(0L, 5L, 10L, NA_integer_)) - - expect_identical(fact(x), f) - expect_identical(fact(x), res) - - # Shouldn't have any NA - expect_false(anyNA(fact(x))) - - # pseudo_id() ordered by appearance, fact() has pre-set ordering - expect_identical(pseudo_id(f), id) - - # factors store levels as characters - o <- order(as.integer(levels(f))) - expect_identical(o, 1:4) -}) - -# fact.integer() ---- - -test_that("fact.integer() works", { - expect_equal( - fact(struct(1L, c("foo", "integer"))), - new_fact(1L, levels = 1L) - ) -}) - -# fact.factor() ---- - -test_that("fact.factor() works", { - x <- factor(letters) - class(x) <- c("fact", "factor") - expect_identical(fact(x), x) - - x <- ordered(letters) - class(x) <- c("fact", "ordered", "factor") - expect_identical(fact(x), x) - - x <- struct(1L, c("fact", "factor"), levels = c("a", NA_character_)) - expect_identical(fact(x), x) - - # fact.fact() checks for NA and adds - x <- factor(c(1, NA, 2)) - expect_identical(levels(fact(x)), c("1", "2", NA_character_)) - - # moves NA to the end and reordered when number - x <- factor(c(1, NA, 2), levels = c(2, NA, 1), exclude = NULL) - res <- new_fact(c(1, 3, 2), levels = c(1, 2, NA)) - expect_identical(fact(x), res) - - x <- factor(c(NA, TRUE, FALSE)) - res <- new_fact(c(3L, 1L, 2L), levels = c(TRUE, FALSE, NA)) - expect_identical(fact(x), res) - - x <- factor(c(NA, TRUE, FALSE), exclude = NULL) - res <- new_fact(c(3L, 1L, 2L), levels = c(TRUE, FALSE, NA)) - expect_identical(fact(x), res) -}) - -# fact.haven_labelled() ---- - -test_that("fact.haven_labelled() works", { - skip_if_not_installed("haven") - .haven_as_factor <- "haven" %:::% "as_factor.haven_labelled" - haven_as_fact <- function(...) { - res <- fact(.haven_as_factor(...)) - attr(res, "label") <- exattr(..1, "label") - res - } - - expect_id_fact <- function(x) { - testthat::expect_identical( - fact(x), - haven_as_fact(x), - ignore_attr = c("uniques", "na") - ) - } - - # Integers - r <- rep(1:3, 2) - x <- haven::labelled(r, labels = c(good = 1, bad = 3)) - expect_id_fact(x) - - x <- haven::labelled(r, labels = c(good = 1, bad = 3), label = "this") - expect_id_fact(x) - - x <- haven::labelled( - r, - labels = c(good = 1, neutral = 2, bad = 3), - label = "this" - ) - expect_id_fact(x) - - x <- haven::labelled(r, label = "this") - expect_id_fact(x) - - # Doubles - x <- haven::labelled(c(0, 0.5, 1), c(a = 0, b = 1)) - expect_id_fact(x) - - # Character - x <- haven::labelled(letters, c(good = "j", something = "m", cool = "b")) - expect_id_fact(x) - - # Unique not in levels; levels not in unique - x <- haven::labelled( - c(-10, 20, 40, 60), - labels = c(a = 10, b = 20, c = 30, d = 40), - label = "foo" - ) - expect_id_fact(x) -}) - -# nas ---- - -test_that("fact() correctly labels NAs [#24]", { - expect_equal( - fact(c(NA, "a", "b")), - new_fact(c(3L, 1L, 2L), c("a", "b", NA)) - ) - - expect_equal( - fact(c(NA, 1, 3)), - new_fact(c(3L, 1L, 2L), c(1, 3, NA)) - ) - - expect_equal( - fact(c(1, NA, NA, 3)), - new_fact(c(1L, 3L, 3L, 2L), c(1, 3, NA)) - ) - - expect_equal( - fact(c(TRUE, TRUE, NA, FALSE, TRUE)), - new_fact(c(1L, 1L, 3L, 2L, 1L), c(TRUE, FALSE, NA)) - ) -}) - - -test_that("fact() ignores NaN", { - # ignore NaN - res <- fact(c(1, 2, NA, 3, NaN)) - exp <- struct( - c(1L, 2L, 4L, 3L, 4L), - class = c("fact", "factor"), - levels = c("1", "2", "3", NA), - uniques = c(1, 2, 3, NA), - na = 4L - ) - - expect_identical(res, exp) -}) - - -# ordering ---- - -test_that("as_ordered() works", { - res <- fact(c(1:3, NA_integer_)) - exp <- struct( - c(1:3, NA_integer_), - c("fact", "ordered", "factor"), - levels = as.character(1:3), - uniques = 1:3, - na = 0L - ) - expect_identical(as_ordered(res), exp) -}) - -test_that("as_ordered() doesn't duplicate class", { - res <- class(as_ordered(as.ordered(letters[1:3]))) - expect_identical(res, c("fact", "ordered", "factor")) -}) - - -# fact.default() ---------------------------------------------------------- - -test_that("fact.default() fails", { - expect_error(fact(struct(NULL, "foo"))) -}) - - -# `fact_levels<-`() ------------------------------------------------------- - -test_that("`fact_levels<-`() works", { - x <- fact(1:3) - fact_levels(x) <- 1:4 - exp <- struct( - 1:3, - class = c("fact", "factor"), - levels = as.character(1:4), - uniques = 1:4, - na = 0L - ) - expect_identical(x, exp) -}) - - -# fact_coerce_levels() ---------------------------------------------------- - -test_that("fact_coerce_levels() works", { - x <- as.Date("2021-09-03") + 0:2 - expect_equal(fact_coerce_levels(as.character(x)), x) - - # Be careful about setting a time zone - # Not very good for dealing with local - # NOTE r-dev after 4.2.1 has some weird behavior with the 0 and returns: - # ('2021-09-03', '2021-09-03 00:00:01', '2021-09-03 00:00:02') - x <- as.POSIXlt("2021-09-03", tz = "UTC") + 1:3 - expect_equal(fact_coerce_levels(as.character(x)), x) - - x <- as.POSIXlt("2021-09-03", tz = "UTC") + 1:3 - expect_equal(fact_coerce_levels(as.character(x)), x) -}) - - -# try_numeric() ----------------------------------------------------------- - -test_that("try_numeric() works", { - x <- 1 - expect_identical(try_numeric(x), x) - - x <- c(NA, NA) - expect_identical(try_numeric(x), x) - - x <- c("a", 1) - expect_identical(try_numeric(x), x) - - x <- c(1, NA, 2) - expect_identical(try_numeric(as.character(x)), x) -}) - - -# drop_levels ------------------------------------------------------------- - -test_that("drop_levels() works", { - x <- factor(1, 1:2) - exp <- factor(1, 1) - expect_equal(drop_levels(x), exp) - - df <- dataframe(x = x, y = 1) - df_exp <- dataframe(x = exp, y = 1) - expect_equal(drop_levels(df), df_exp) - - # facts and ordered - x <- fact(1:10) - expect_identical(drop_levels(x), x) - - x <- as_ordered(factor(1, 1:2)) - exp <- struct( - 1L, - class = c("fact", "ordered", "factor"), - levels = "1", - uniques = 1L, - na = 0L - ) - expect_equal(drop_levels(x), exp) -}) - - -# fact_reverse() ---------------------------------------------------------- - -test_that("fact_reverse() works", { - res <- fact_reverse(1:4) - exp <- new_fact(4:1, 4:1) - expect_identical(res, exp) - - res <- fact_reverse(as_ordered(1:4)) - exp <- new_fact(4:1, 4:1, ordered = TRUE) - expect_identical(res, exp) - - res <- fact_reverse(c(1:3, NA)) - exp <- new_fact(c(3:1, 4L), c(3:1, NA)) - expect_identical(res, exp) - - res <- fact_reverse(as_ordered(c(1:3, NA))) - exp <- struct( - c(3:1, NA), - class = c("fact", "ordered", "factor"), - levels = c("3", "2", "1"), - uniques = 3:1, - na = 0L - ) - - expect_identical(res, exp) -}) - - - -# other methods ----------------------------------------------------------- - -test_that("[.fact() works", { - x <- fact(1:3) - x1 <- do.call(structure, c(1, attributes(x))) - x2 <- do.call(structure, c(2, attributes(x))) - expect_identical(x[1], x1) - expect_identical(x[2], x2) -}) - -test_that("is.na.fact(), works", { - x <- fact(c(1, 2, NA, 3)) - res <- is.na(x) - exp <- c(FALSE, FALSE, FALSE, FALSE) - expect_identical(res, exp) - - x <- fact_na(c(1, 2, NA, 3)) - res <- is.na(x) - exp <- c(FALSE, FALSE, TRUE, FALSE) - expect_identical(res, exp) - - x <- fact_na(c("a", "b", "c")) - res <- is.na(x) - exp <- c(FALSE, FALSE, FALSE) - expect_identical(res, exp) -}) - -test_that("as.integer.fact() works", { - x <- fact(c(1, 2, NA, 3)) - res <- as.integer(x) - exp <- c(1L, 2L, NA_integer_, 3L) - expect_identical(res, exp) -}) - -test_that("as.integer.fact() works", { - x <- fact(c(1, 2, NA, 3)) - res <- as.double(x) - exp <- c(1, 2, NA_real_, 3) - expect_identical(res, exp) - expect_identical(as.numeric(x), exp) -}) - -test_that("unique.fact() works", { - x <- fact(c(1, 2, NA, 3, 2)) - exp <- fact(c(1, 2, NA, 3)) - res <- unique(x) - expect_identical(exp, res) - - x <- as_ordered(x) - exp <- as_ordered(exp) - res <- unique(x) - expect_identical(exp, res) -}) - -test_that("as.Date.fact() works", { - exp <- as.Date(c("2022-01-02", NA, "1908-12-21")) - res <- as.Date(fact(exp)) - expect_identical(exp, res) - - x <- c("01-01-2022", "01-02-2000") - exp <- as.Date(x, "%d-%m-%Y") - res <- as.Date(fact(x), "%d-%m-%Y") - expect_identical(exp, res) -}) - -test_that("as.character.fact() works", { - exp <- c("a", NA_character_, "b", "b", "a") - res <- as.character(fact(exp)) - expect_identical(exp, res) -}) - -# snapshots --------------------------------------------------------------- - -test_that("snapshots", { - expect_snapshot(fact(character())) - expect_snapshot(fact(1:5)) - expect_snapshot(print(fact(1:100), max_levels = TRUE)) - expect_snapshot(print(fact(1:100), max_levels = 20)) - expect_snapshot(print(fact(1:100), max_levels = 100)) -})