R/ymon-seq.R

In DavisVaughan/datea: Extended Date Classes

#' Sequence generation
#'
#' @description
#' This [seq()] method generates regular sequences of ymon objects. It functions
#' the same as the default `seq()` method, except that fractional sequences
#' that might be generated by `seq(to =, length.out =)` are not allowed.
#'
#' `seq()` methods require a `from` argument, and any combination of two of the
#' other arguments. The only combination not allowed is `length.out` and
#' `along.with`, because they represent the same information.
#'
#' @param from `[ymon]`
#'
#'   A ymon.
#'
#' @param to `[ymon]`
#'
#'   Optional. A ymon.
#'
#' @param by `[integer(1)]`
#'
#'   Optional. A single integer representing the step size. Must be negative
#'   if `to` is supplied and the sequence between `from` and `to` is decreasing.
#'
#' @param length.out `[integer(1)]`
#'
#'   Optional. A single integer representing the final output size. If `to` is
#'   supplied, this must divide the distance between `from` and `to` into
#'   equally spaced pieces, otherwise an error is thrown.
#'
#' @param along.with `[vector]`
#'
#'   Optional. A vector to take the length of. The length of the vector is used
#'   as the `length.out` value.
#'
#' @param ...
#'
#'   Not used.
#'
#' @export
#' @examples
#' x <- ymon(1970, 1)
#'
#' seq(x, by = 3, length.out = 10)
#'
#' seq(x, to = ymon(1980, 1), by = 6)
#'
#' seq(x, to = ymon(1980, 1), length.out = 5)
#'
#' # 4 values between 1970-01 and 1970-04, there
#' # is no way to divide these evenly into 3 equally spaced pieces!
#' try(seq(x, to = ymon(1970, 4), length.out = 3))
seq.ymon <- function(from, to, by, length.out, along.with, ...) {
  if (!missing(...)) {
    ellipsis::check_dots_empty()
  }

  vec_assert(from, size = 1L)
  if (is.na(from)) {
    abort("`from` can't be `NA`.")
  }

  has_to <- !missing(to)
  has_by <- !missing(by)
  has_lo <- !missing(length.out)
  has_aw <- !missing(along.with)

  if (has_aw) {
    if (has_lo) {
      abort("Can only specify one of `length.out` and `along.with`.")
    } else {
      has_lo <- TRUE
      length.out <- length(along.with)
    }
  }

  n_has <- sum(has_to, has_by, has_lo)

  if (n_has != 2L) {
    abort("Must specify exactly two of `to`, `by`, and either `length.out` or `along.with`.")
  }

  if (has_to) {
    vec_assert(to, size = 1L)
    if (!is_ymon(to)) {
      abort("`to` must be a ymon.")
    }
    if (is.na(to)) {
      abort("`to` can't be `NA`.")
    }
  }

  if (has_by) {
    vec_assert(by, size = 1L)
    by <- vec_cast(by, integer())
    if (is.na(by)) {
      abort("`by` can't be `NA`.")
    }
    if (identical(by, 0L)) {
      abort("`by` can't be `0`.")
    }
  }

  if (has_lo) {
    vec_assert(length.out, size = 1L)
    length.out <- vec_cast(length.out, integer())
    if (is.na(length.out)) {
      abort("`length.out` can't be `NA`.")
    }
    if (length.out < 0) {
      abort("`length.out` can't be negative.")
    }
  }

  if (has_to) {
    if (has_by) {
      seq_to_by(from, to, by)
    } else {
      seq_to_lo(from, to, length.out)
    }
  } else {
    seq_by_lo(from, by, length.out)
  }
}

seq_to_by <- function(from, to, by) {
  # Base seq() requires negative `by` when creating a decreasing seq, so this
  # helps be compatible with that.
  if (from > to && by > 0L) {
    abort("When `from` is greater than `to`, `by` must be negative.")
  }
  if (from < to && by < 0L) {
    abort("When `from` is less than `to`, `by` must be positive.")
  }

  out <- seq.int(unclass(from), unclass(to), by = by)

  new_ymon(out)
}

seq_to_lo <- function(from, to, length.out) {
  out <- seq.int(unclass(from), unclass(to), length.out = length.out)

  tryCatch(
    expr = {
      out <- vec_cast(out, integer())
    },
    vctrs_error_cast_lossy = function(cnd) {
      abort("`length.out` / `along.with` must generate a non-fractional sequence between `from` and `to`.")
    }
  )

  new_ymon(out)
}

seq_by_lo <- function(from, by, length.out) {
  out <- seq.int(unclass(from), by = by, length.out = length.out)
  new_ymon(out)
}