#' Represent year-quarter
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' Create or coerce using `yearquarter()`.
#'
#' @inheritSection yearmonth Display
#'
#' @inheritParams yearmonth
#' @inheritParams lubridate::quarter
#'
#' @return year-quarter (`yearquarter`) objects.
#'
#' @seealso [scale_x_yearquarter] and others for ggplot2 scales
#' @family index functions
#' @rdname year-quarter
#' @export
#' @examples
#' # coerce POSIXct/Dates to yearquarter
#' x <- seq(as.Date("2016-01-01"), as.Date("2016-12-31"), by = "1 quarter")
#' yearquarter(x)
#' yearquarter(x, fiscal_start = 6)
#'
#' # parse characters
#' yearquarter(c("2018 Q1", "2018 Qtr1", "2018 Quarter 1"))
#'
#' # seq() and arithmetic
#' qtr <- yearquarter("2017 Q1")
#' seq(qtr, length.out = 10, by = 1) # by 1 quarter
#' qtr + 0:9
#'
#' # display formats
#' format(qtr, format = "%y Qtr%q")
yearquarter <- function(x, fiscal_start = 1) {
UseMethod("yearquarter")
}
#' @rdname year-quarter
#' @param year,quarter A vector of numerics give years and quarters.
#' @export
#' @examples
#'
#' make_yearquarter(year = 2021, quarter = 2:3)
#' make_yearquarter(year = 2020:2021, quarter = 2:3)
make_yearquarter <- function(year = 1970L, quarter = 1L, fiscal_start = 1) {
lst <- vec_recycle_common(year = year, quarter = quarter)
if (any(lst$quarter > 4 | lst$quarter < 1)) {
abort("Quarters can't be less than 1 or greater than 4.")
}
yearquarter(4 * (lst$year - 1970) + lst$quarter - 1, fiscal_start)
}
#' @export
yearquarter.default <- function(x, fiscal_start = 1) {
dont_know(x, "yearquarter")
}
#' @export
yearquarter.NULL <- function(x, fiscal_start = 1) {
new_yearquarter(double(), fiscal_start = 1)
}
#' @export
yearquarter.logical <- function(x, ...) {
if (is.logical(x) && all(is.na(x))) {
new_yearquarter(0) + NA_real_
} else {
dont_know(x, "yearquarter")
}
}
#' @export
yearquarter.POSIXct <- function(x, fiscal_start = 1) {
yr <- year(x)
mth <- fiscal_start + (month(x) - fiscal_start) %/% 3 * 3
mth0 <- mth == 0
mth1 <- mth == -1
mth[mth0] <- 12
mth[mth1] <- 11
lgl <- mth0 | mth1
vec_slice(yr, lgl) <- vec_slice(yr, lgl) - 1
new_yearquarter(make_date(yr, mth), fiscal_start)
}
#' @export
yearquarter.POSIXlt <- yearquarter.POSIXct
#' @export
yearquarter.Date <- yearquarter.POSIXct
#' @export
yearquarter.character <- function(x, fiscal_start = 1) {
# exact matching with q, qtr, or quarter
key_words <- regmatches(x, gregexpr("[[:alpha:]]+", x))
if (all(grepl("^(q|qtr|quarter)$", key_words, ignore.case = TRUE))) {
yr_qtr <- regmatches(x, gregexpr("[[:digit:]]+", x))
digits_lgl <- map_lgl(yr_qtr, function(.x) !has_length(.x, 2))
digits_len <- map_int(yr_qtr, function(.x) sum(nchar(.x)))
if (any(digits_lgl) || any(digits_len != 5)) {
abort("Character strings are not in a standard unambiguous format.")
}
yr_lgl <- map(yr_qtr, function(.x) grepl("[[:digit:]]{4}", .x))
yr <- as.integer(map2_chr(yr_qtr, yr_lgl, function(.x, .y) .x[.y]))
qtr <- as.integer(map2_chr(yr_qtr, yr_lgl, function(.x, .y) .x[!.y]))
if (any(qtr > 4 | qtr < 1)) {
abort("Quarters can't be less than 1 or greater than 4.")
}
yearquarter(4 * (yr - 1970) + qtr - 1, fiscal_start)
} else {
assertDate(x)
yearquarter(anydate(x), fiscal_start)
}
}
#' @export
yearquarter.yearweek <- yearquarter.POSIXct
#' @export
yearquarter.yearmonth <- yearquarter.POSIXct
#' @export
yearquarter.yearquarter <- function(x, fiscal_start = attr(x, "fiscal_start")) {
fs <- fiscal_start(x)
mth <- fiscal_start - fs
new_yearquarter(
new_date(x) + period(year = -(fs == 1) + (fiscal_start == 1), month = mth),
fiscal_start)
}
#' @export
yearquarter.numeric <- function(x, fiscal_start = 1) {
date0 <- make_date(1969 + as.integer(fiscal_start == 1), fiscal_start)
new_yearquarter(date0 + period(month = x * 3), fiscal_start)
}
#' @export
yearquarter.yearqtr <- function(x, fiscal_start = 1) {
year <- trunc(x)
last_month <- trunc((x %% 1) * 4 + 1) * 3
first_month <- last_month - 2
result <- make_date(year, first_month, 1)
new_yearquarter(result, fiscal_start)
}
new_yearquarter <- function(x = double(), fiscal_start = 1) {
if (!has_length(fiscal_start, 1)) {
abort("`fiscal_start` must be of length 1.")
}
if (fiscal_start < 1 || fiscal_start > 12) {
abort("`fiscal_start` only accepts a value between 1 and 12.")
}
new_vctr(x, fiscal_start = fiscal_start, class = "yearquarter")
}
fiscal_start <- function(x) {
attr(x, "fiscal_start") %||% 1
}
#' @rdname year-quarter
#' @export
is_yearquarter <- function(x) {
inherits(x, "yearquarter")
}
#' @export
is.numeric.yearquarter <- function(x) {
FALSE
}
#' @export
tz.yearquarter <- function(x) {
"UTC"
}
# diff.yearquarter <- function(x, lag = 1, differences = 1, ...) {
# out <- diff((year(x) - 1970) * 4 + quarter(x),
# lag = lag, differences = differences
# )
# structure(out, class = "difftime", units = "quarters")
# }
#' @rdname tsibble-vctrs
#' @method vec_cast yearquarter
#' @export
vec_cast.yearquarter <- function(x, to, ...) {
UseMethod("vec_cast.yearquarter")
}
#' @export
vec_cast.Date.yearquarter <- function(x, to, ...) {
new_date(x)
}
#' @export
vec_cast.POSIXct.yearquarter <- function(x, to, ...) {
as.POSIXct(new_date(x), ...)
}
#' @export
vec_cast.double.yearquarter <- function(x, to, ...) {
base <- yearquarter(0, fiscal_start(x))
4 * (year(x) - year(base)) + quarter(x) - quarter(base)
}
#' @export
vec_cast.POSIXlt.yearquarter <- function(x, to, ...) {
as.POSIXlt(new_date(x), ...)
}
#' @export
vec_cast.yearquarter.yearquarter <- function(x, to, ...) {
yearquarter(x, fiscal_start(to))
}
#' @export
vec_cast.character.yearquarter <- function(x, to, ...) {
format(x)
}
#' @rdname tsibble-vctrs
#' @method vec_ptype2 yearquarter
#' @export
vec_ptype2.yearquarter <- function(x, y, ...) {
UseMethod("vec_ptype2.yearquarter", y)
}
#' @export
vec_ptype2.yearquarter.POSIXct <- function(x, y, ...) {
new_datetime()
}
#' @export
vec_ptype2.POSIXct.yearquarter <- function(x, y, ...) {
new_datetime()
}
#' @export
vec_ptype2.yearquarter.Date <- function(x, y, ...) {
new_date()
}
#' @export
vec_ptype2.yearquarter.yearquarter <- function(x, y, ...) {
if (fiscal_start(x) != fiscal_start(y)) {
abort("Can't combine <yearquarter> with different `fiscal_start`.")
}
new_yearquarter(fiscal_start = fiscal_start(x))
}
#' @export
vec_ptype2.Date.yearquarter <- function(x, y, ...) {
new_date()
}
#' @rdname tsibble-vctrs
#' @method vec_arith yearquarter
#' @export
vec_arith.yearquarter <- function(op, x, y, ...) {
UseMethod("vec_arith.yearquarter", y)
}
#' @method vec_arith.yearquarter default
#' @export
vec_arith.yearquarter.default <- function(op, x, y, ...) {
stop_incompatible_op(op, x, y)
}
#' @method vec_arith.yearquarter numeric
#' @export
vec_arith.yearquarter.numeric <- function(op, x, y, ...) {
if (op == "+") {
new_yearquarter(as_date(x) + period(months = y * 3), fiscal_start(x))
} else if (op == "-") {
new_yearquarter(as_date(x) - period(months = y * 3), fiscal_start(x))
} else {
stop_incompatible_op(op, x, y)
}
}
#' @method vec_arith.yearquarter yearquarter
#' @export
vec_arith.yearquarter.yearquarter <- function(op, x, y, ...) {
if (op == "-") {
as.double(x) - as.double(y)
} else {
stop_incompatible_op(op, x, y)
}
}
#' @method vec_arith.numeric yearquarter
#' @export
vec_arith.numeric.yearquarter <- function(op, x, y, ...) {
if (op == "+") {
yearquarter(period(months = x * 3) + as_date(y), fiscal_start(y))
} else {
stop_incompatible_op(op, x, y)
}
}
#' @method vec_arith.yearquarter MISSING
#' @export
vec_arith.yearquarter.MISSING <- function(op, x, y, ...) {
switch(op,
`-` = x,
`+` = x,
stop_incompatible_op(op, x, y)
)
}
#' @export
format.yearquarter <- function(x, format = "%Y Q%q", ...) {
fs <- fiscal_start(x)
yrqtr <- quarter(x, with_year = TRUE, fiscal_start = fs)
yr <- trunc(yrqtr)
qtr <- round(yrqtr %% 1 * 10)
qtr_sub <- map_chr(formatC(qtr), function(z) gsub("%q", z, x = format))
qtr_sub[is.na(qtr_sub)] <- "-" # NA formats cause errors
format.Date(make_date(yr, qtr * 3 - 2), format = qtr_sub)
}
#' @rdname tsibble-vctrs
#' @export
obj_print_data.yearquarter <- function(x, ...) {
if (length(x) == 0) return()
print(format(x))
}
#' @export
obj_print_footer.yearquarter <- function(x, ...) {
cat_line("# Year starts on: ", fmt_month(fiscal_start(x)))
}
fmt_month <- function(x) {
month.name[x]
}
#' @export
vec_ptype_abbr.yearquarter <- function(x, ...) {
"qtr"
}
#' @export
seq.yearquarter <- function(from, to, by, length.out = NULL, along.with = NULL,
...) {
fs <- fiscal_start(from)
from <- vec_cast(from, new_date())
if (!is_missing(to)) {
to <- vec_cast(to, new_date())
}
if (is_missing(by)) {
new_yearquarter(seq_date(
from = from, to = to, length.out = length.out,
along.with = along.with, ...
), fs)
} else {
bad_by(by)
by_qtr <- paste(by, "quarter")
new_yearquarter(seq_date(
from = from, to = to, by = by_qtr, length.out = length.out,
along.with = along.with, ...
), fs)
}
}
#' @export
seq.ordered <- function(from, to, by, ...) {
bad_by(by)
lvls <- levels(from)
idx_from <- which(lvls %in% from)
idx_to <- which(lvls %in% to)
idx <- seq.int(idx_from, idx_to, by = by)
ordered(lvls[idx], levels = lvls)
}
#' @rdname year-quarter
#' @export
#' @examples
#'
#' # `fiscal_year()` helps to extract fiscal year
#' y <- yearquarter(as.Date("2020-06-01"), fiscal_start = 6)
#' fiscal_year(y)
#' lubridate::year(y) # calendar years
fiscal_year <- function(x) {
stopifnot(is_yearquarter(x))
trunc(quarter(x, TRUE, fiscal_start(x)))
}
#' @export
union.yearquarter <- set_ops("yearquarter", op = "union")
#' @export
intersect.yearquarter <- set_ops("yearquarter", op = "intersect")
#' @export
setdiff.yearquarter <- set_ops("yearquarter", op = "setdiff")
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.