tests/testthat/helper-rational.R

In vctrs: Vector Helpers

# Rational record class from the S3 vector vignette

new_rational <- function(n = integer(), d = integer()) {
  if (!is_integer(n)) {
    abort("`n` must be an integer.")
  }
  if (!is_integer(d)) {
    abort("`d` must be an integer.")
  }
  new_rcrd(list(n = n, d = d), class = "vctrs_rational")
}

rational <- function(n, d) {
  args <- vec_cast_common(n, d, .to = integer())
  args <- vec_recycle_common(!!!args)
  new_rational(args[[1L]], args[[2L]])
}

format.vctrs_rational <- function(x, ...) {
  n <- field(x, "n")
  d <- field(x, "d")
  out <- paste0(n, "/", d)
  out[is.na(n) | is.na(d)] <- NA
  out
}

vec_proxy_equal.vctrs_rational <- function(x) {
  n <- field(x, "n")
  d <- field(x, "d")
  gcd <- gcd(n, d)
  data.frame(n = n / gcd, d = d / gcd)
}
gcd <- function(x, y) {
  r <- x %% y
  ifelse(r, gcd(y, r), y)
}

vec_proxy_compare.vctrs_rational <- function(x, ...) {
  field(x, "n") / field(x, "d")
}

rational_methods <- list(
  vec_ptype_abbr.vctrs_rational = function(x, ...) {
    "rtnl"
  },
  vec_ptype_full.vctrs_rational = function(x, ...) {
    "rational"
  },

  vec_ptype2.vctrs_rational = function(x, y, ...) {
    UseMethod("vec_ptype2.vctrs_rational")
  },
  vec_ptype2.vctrs_rational.vctrs_rational = function(x, y, ...) {
    new_rational()
  },
  vec_ptype2.vctrs_rational.integer = function(x, y, ...) {
    new_rational()
  },
  vec_ptype2.integer.vctrs_rational = function(x, y, ...) {
    new_rational()
  },

  vec_cast.vctrs_rational = function(x, to, ...) {
    UseMethod("vec_cast.vctrs_rational")
  },
  vec_cast.vctrs_rational.vctrs_rational = function(x, to, ...) {
    x
  },
  vec_cast.double.vctrs_rational = function(x, to, ...) {
    field(x, "n") / field(x, "d")
  },
  vec_cast.vctrs_rational.integer = function(x, to, ...) {
    rational(x, 1)
  },

  vec_proxy_equal.vctrs_rational = vec_proxy_equal.vctrs_rational,
  vec_proxy_compare.vctrs_rational = vec_proxy_compare.vctrs_rational
)

local_rational_class <- function(frame = caller_env()) {
  local_methods(.frame = frame, !!!rational_methods)
}