Implement to_int() as proof of concept. (#3)

* Implement to_int() as proof of concept.

* Add cli to imports.

* Add tests for factors.

DESCRIPTION

@@ -10,6 +10,10 @@ License: MIT + file LICENSE
 URL: https://github.com/jonthegeek/ykwim,
     https://jonthegeek.github.io/ykwim/
 BugReports: https://github.com/jonthegeek/ykwim/issues
+Imports: 
+    cli,
+    rlang (>= 1.1.0),
+    vctrs
 Suggests: 
     testthat (>= 3.0.0)
 Config/testthat/edition: 3

NAMESPACE

@@ -1,2 +1,13 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(.to_int_impl,"NULL")
+S3method(.to_int_impl,character)
+S3method(.to_int_impl,complex)
+S3method(.to_int_impl,default)
+S3method(.to_int_impl,double)
+S3method(.to_int_impl,factor)
+S3method(.to_int_impl,hexmode)
+S3method(.to_int_impl,integer)
+S3method(.to_int_impl,logical)
+export(to_int)
+import(vctrs)

R/common.R

@@ -0,0 +1,66 @@
+.return_if_clear <- function(x,
+                             to,
+                             allow_empty,
+                             allow_na,
+                             x_arg = rlang::caller_arg(x),
+                             call = rlang::caller_env()) {
+  .check_na(x = x, to = to, allow_na = allow_na, x_arg = x_arg, call = call)
+  # .check_empty(x, allow_empty, x_arg, call)
+  return(x)
+}
+
+.check_na <- function(x,
+                      to,
+                      allow_na,
+                      x_arg = rlang::caller_arg(x),
+                      call = rlang::caller_env()) {
+  if (allow_na || !any(is.na(x))) {
+    return(invisible(NULL))
+  }
+  locations <- which(is.na(x))
+  cli::cli_abort(
+    c(
+      "{.arg {x_arg}} must not contain NA values.",
+      "*" = "NA locations: {locations}"
+    ),
+    call = call
+  )
+}
+
+.stop_incompatible <- function(x,
+                               to,
+                               failures,
+                               due_to,
+                               x_arg = rlang::caller_arg(x),
+                               call = rlang::caller_env()) {
+  x_class <- .obj_type(x)
+  to_class <- .obj_type(to)
+  locations <- which(failures)
+  cli::cli_abort(
+    c(
+      "{.arg {x_arg}} {.cls {x_class}} must be coercible to {.cls {to_class}}",
+      x = "Can't convert some values due to {due_to}.",
+      "*" = "Locations: {locations}"
+    ),
+    call = call
+  )
+}
+
+# Derived from use_standalone("r-lib/rlang", "standalone-obj-type.R") but
+# simplified.
+.obj_type <- function(x) {
+  if (missing(x)) {
+    return("unknown type") # nocov
+  }
+
+  # Anything with a class.
+  if (is.object(x)) {
+    if (inherits(x, "quosure")) { # nocov start
+      return("quosure")
+    } # nocov end
+    return(class(x)[[1L]])
+  }
+
+  # Leftovers
+  return(typeof(x))
+}

R/int.R

@@ -0,0 +1,150 @@
+#' Cast an argument to integer
+#'
+#' More details soon.
+#'
+#' @param x The argument to cast.
+#' @param allow_empty Logical; is it ok for the argument to have length 0?
+#' @param allow_na Logical; are NA values ok?
+#' @param allow_null Logical; is NULL an acceptable value?
+#' @param x_arg Argument name for x. The automatic value will work in most
+#'   cases, or pass it through from higher-level functions to make error
+#'   messages cleaner in unexported functions.
+#' @param call The execution environment of the call. See the `call` argument of
+#'   `rlang::abort()` for more information.
+#'
+#' @return The argument as an integer.
+#' @export
+#'
+#' @examples
+#' to_int(1:10)
+#' to_int("1")
+#' to_int(1 + 0i)
+to_int <- function(x,
+                   allow_empty = TRUE,
+                   allow_na = TRUE,
+                   allow_null = TRUE,
+                   x_arg = rlang::caller_arg(x),
+                   call = rlang::caller_env()) {
+  x_arg <- force(x_arg)
+  x <- .to_int_impl(x, allow_null = allow_null, x_arg = x_arg, call = call)
+  .return_if_clear(
+    x = x, to = integer(),
+    allow_empty = allow_empty, allow_na = allow_na,
+    x_arg = x_arg, call = call
+  )
+}
+
+.to_int_impl <- function(x,
+                         allow_null,
+                         x_arg = rlang::caller_arg(x),
+                         call = rlang::caller_env()) {
+  UseMethod(".to_int_impl")
+}
+
+
+#' @export
+.to_int_impl.integer <- function(x,
+                                 ...,
+                                 x_arg = rlang::caller_arg(x),
+                                 call = rlang::caller_env()) {
+  return(x)
+}
+
+#' @export
+.to_int_impl.hexmode <- function(x,
+                                 ...,
+                                 x_arg = rlang::caller_arg(x),
+                                 call = rlang::caller_env()) {
+  return(as.integer(x))
+}
+
+#' @export
+.to_int_impl.NULL <- function(x,
+                              allow_null,
+                              x_arg = rlang::caller_arg(x),
+                              call = rlang::caller_env()) {
+  if (allow_null) {
+    return(NULL)
+  }
+  cli::cli_abort(
+    c("{.arg {x_arg}} can't be {.cls NULL}."),
+    call = call
+  )
+}
+
+#' @export
+.to_int_impl.double <- function(x,
+                                ...,
+                                x_arg = rlang::caller_arg(x),
+                                call = rlang::caller_env()) {
+  vec_cast(x, integer(), x_arg = x_arg, call = call)
+}
+
+#' @export
+.to_int_impl.logical <- function(x,
+                                 ...,
+                                 x_arg = rlang::caller_arg(x),
+                                 call = rlang::caller_env()) {
+  vec_cast(x, integer(), x_arg = x_arg, call = call)
+}
+
+#' @export
+.to_int_impl.character <- function(x,
+                                   ...,
+                                   x_arg = rlang::caller_arg(x),
+                                   call = rlang::caller_env()) {
+  cast <- suppressWarnings(as.integer(x))
+  cast_double <- suppressWarnings(as.double(x))
+  x_na <- is.na(x)
+  non_numbers <- xor(x_na, is.na(cast))
+  bad_precision <- cast != cast_double & !x_na
+  failures <- non_numbers | bad_precision
+
+  if (!any(failures)) {
+    return(cast)
+  }
+
+  if (any(non_numbers)) {
+    .stop_incompatible(
+      x, integer(), non_numbers, due_to = "incompatible values", x_arg, call
+    )
+  }
+
+  .stop_incompatible(
+    x, integer(), bad_precision, due_to = "loss of precision", x_arg, call
+  )
+}
+
+#' @export
+.to_int_impl.factor <- function(x,
+                                ...,
+                                x_arg = rlang::caller_arg(x),
+                                call = rlang::caller_env()) {
+  return(
+    .to_int_impl(as.character(x), ..., x_arg = x_arg, call = call)
+  )
+}
+
+#' @export
+.to_int_impl.complex <- function(x,
+                                 ...,
+                                 x_arg = rlang::caller_arg(x),
+                                 call = rlang::caller_env()) {
+  cast <- suppressWarnings(as.integer(x))
+  x_na <- is.na(x)
+  failures <- (cast != x & !x_na) | xor(x_na, is.na(cast))
+  if (!any(failures)) {
+    return(cast)
+  }
+  .stop_incompatible(
+    x, integer(), failures, due_to = "non-zero complex components", x_arg, call
+  )
+}
+
+#' @export
+.to_int_impl.default <- function(x,
+                                 ...,
+                                 x_arg = rlang::caller_arg(x),
+                                 call = rlang::caller_env()) {
+  vec_cast(x, integer(), x_arg = x_arg, call = call)
+}

R/ykwim-package.R

@@ -2,5 +2,6 @@
 "_PACKAGE"
 
 ## usethis namespace: start
+#' @import vctrs
 ## usethis namespace: end
 NULL

README.Rmd

@@ -38,41 +38,38 @@ remotes::install_github("jonthegeek/ykwim")
 
 ## Usage
 
-Coming soon. 
-The general idea is shown below.
-Note: This code is currently simulated, but this is the goal.
+Use within functions to give meaningful error messages for bad argument classes.
 
-```{r simple_example, eval = FALSE}
+For example, perhaps you would like to protect against the case where data is not properly translated from character on load.
+
+Without {ykwim}:
+
+```{r no-ykwim, error = TRUE}
 # Without ykwim.
 my_old_fun <- function(my_arg_name) {
   my_arg_name + 1
 }
-# Perhaps numbers aren't properly translated from character when the data is
-# loaded.
 my_old_fun("1")
-#> Error in my_arg_name + 1 : non-numeric argument to binary operator
+```
 
+```{r with-ykwim-ok}
 my_fun <- function(my_arg_name) {
   my_arg_name <- ykwim::to_int(my_arg_name)
   my_arg_name + 1
 }
 my_fun("1")
-#> [1] 2
+```
 
-# Failures are reported with helpful errors.
+Failures are reported with helpful messages.
+
+```{r with-ykwim-error1, error = TRUE}
 my_fun("1.1")
-#> Error in `my_fun()`:
-#> ! `x` must be coercible to an integer.
-#> ✖ "1.1" is not coercible.
-#> Run `rlang::last_trace()` to see where the error occurred.
+```
+
+The errors help locate issues within vectors.
 
-# The errors help locate issues within vectors.
+```{r with-ykwim-error2, error = TRUE}
 my_fun(c("1", "2", "3.1", "4", "5.2"))
-#> Error in `my_fun()`:
-#> ! `x` must be coercible to an integer.
-#> ✖ "3.1" (element 3) is not coercible.
-#> ✖ "5.2" (element 5) is not coercible.
-#> Run `rlang::last_trace()` to see where the error occurred.
 ```
 
 ## Code of Conduct

README.md

@@ -34,40 +34,50 @@ remotes::install_github("jonthegeek/ykwim")
 
 ## Usage
 
-Coming soon. The general idea is shown below. Note: This code is
-currently simulated, but this is the goal.
+Use within functions to give meaningful error messages for bad argument
+classes.
+
+For example, perhaps you would like to protect against the case where
+data is not properly translated from character on load.
+
+Without {ykwim}:
 
 ``` r
 # Without ykwim.
 my_old_fun <- function(my_arg_name) {
   my_arg_name + 1
 }
-# Perhaps numbers aren't properly translated from character when the data is
-# loaded.
 my_old_fun("1")
-#> Error in my_arg_name + 1 : non-numeric argument to binary operator
+#> Error in my_arg_name + 1: non-numeric argument to binary operator
+```
 
+``` r
 my_fun <- function(my_arg_name) {
   my_arg_name <- ykwim::to_int(my_arg_name)
   my_arg_name + 1
 }
 my_fun("1")
 #> [1] 2
+```
 
-# Failures are reported with helpful errors.
+Failures are reported with helpful messages.
+
+``` r
 my_fun("1.1")
 #> Error in `my_fun()`:
-#> ! `x` must be coercible to an integer.
-#> ✖ "1.1" is not coercible.
-#> Run `rlang::last_trace()` to see where the error occurred.
+#> ! `my_arg_name` <character> must be coercible to <integer>
+#> ✖ Can't convert some values due to loss of precision.
+#> • Locations: 1
+```
 
-# The errors help locate issues within vectors.
+The errors help locate issues within vectors.
+
+``` r
 my_fun(c("1", "2", "3.1", "4", "5.2"))
 #> Error in `my_fun()`:
-#> ! `x` must be coercible to an integer.
-#> ✖ "3.1" (element 3) is not coercible.
-#> ✖ "5.2" (element 5) is not coercible.
-#> Run `rlang::last_trace()` to see where the error occurred.
+#> ! `my_arg_name` <character> must be coercible to <integer>
+#> ✖ Can't convert some values due to loss of precision.
+#> • Locations: 3 and 5
 ```
 
 ## Code of Conduct