Nothing
#' Represent year-month
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' Create or coerce using `yearmonth()`.
#'
#' @section Display:
#' Use `format()` to display `yearweek`, `yearmonth`, and `yearquarter` objects
#' in required formats.
#' Please see [`strptime()`] details for supported conversion specifications.
#'
#' @param x Other object.
#' @param format A vector of strings to specify additional formats of `x` (e.g. `%Y%m`),
#' if a warning or an error occurs.
#' @param ... Further arguments to methods.
#'
#' @return year-month (`yearmonth`) objects.
#'
#' @seealso [scale_x_yearmonth] and others for ggplot2 scales
#' @family index functions
#' @rdname year-month
#' @export
#' @examples
#' # coerce POSIXct/Dates to yearmonth
#' x <- seq(as.Date("2016-01-01"), as.Date("2016-12-31"), by = "1 month")
#' yearmonth(x)
#'
#' # parse characters
#' yearmonth(c("2018 Jan", "2018-01", "2018 January"))
#'
#' # seq() and arithmetic
#' mth <- yearmonth("2017-11")
#' seq(mth, length.out = 10, by = 1) # by 1 month
#' mth + 0:9
#'
#' # display formats
#' format(mth, format = "%y %m")
#'
#' # units since 1970 Jan
#' as.double(yearmonth("1969 Jan") + 0:24)
yearmonth <- function(x, ...) {
UseMethod("yearmonth")
}
#' @rdname year-month
#' @param year,month A vector of numerics give years and months.
#' @export
#' @examples
#'
#' make_yearmonth(year = 2021, month = 10:11)
#' make_yearmonth(year = 2020:2021, month = 10:11)
make_yearmonth <- function(year = 1970L, month = 1L) {
lst <- vec_recycle_common(year = year, month = month)
new_yearmonth(make_date(lst$year, lst$month, 1))
}
#' @export
yearmonth.default <- function(x, ...) {
dont_know(x, "yearmonth")
}
#' @export
yearmonth.NULL <- function(x, ...) {
new_yearmonth()
}
#' @export
yearmonth.logical <- function(x, ...) {
if (is.logical(x) && all(is.na(x))) {
new_yearmonth(0) + NA_real_
} else {
dont_know(x, "yearmonth")
}
}
#' @export
yearmonth.POSIXct <- function(x, ...) {
new_yearmonth(floor_date(as_date(x), unit = "months"))
}
#' @export
yearmonth.POSIXlt <- yearmonth.POSIXct
#' @export
yearmonth.Date <- function(x, ...) {
new_yearmonth(floor_date(x, unit = "months"))
}
#' @rdname year-month
#' @export
yearmonth.character <- function(x, format = NULL, ...) {
fmts <- c("%B %Y", "%b %Y", "%Y M%m", "%Y m%m")
dates <- with_anytime_formats({
assertDate(x)
anydate(x)
}, formats_before = format, formats_after = fmts)
if (is_null(format)) {
if (any(!grepl("\\D", x))) { # all numbers without delimiter
warn(c(
"`yearmonth()` may yield unexpected results.",
i = "Please use arg `format` to supply formats."))
}
}
yearmonth(dates)
}
#' @export
yearmonth.yearweek <- yearmonth.POSIXct
#' @export
yearmonth.yearmonth <- function(x, ...) {
x
}
#' @export
yearmonth.numeric <- function(x, ...) {
new_yearmonth(0) + x
}
#' @export
yearmonth.yearmon <- function(x, ...) {
year <- trunc(x)
month <- formatC(round((x %% 1) * 12) %% 12 + 1, flag = 0, width = 2)
result <- make_date(year, month, 1)
new_yearmonth(result)
}
new_yearmonth <- function(x = double()) {
new_vctr(x, class = "yearmonth")
}
#' @rdname year-month
#' @export
is_yearmonth <- function(x) {
inherits(x, "yearmonth")
}
#' @export
is.numeric.yearmonth <- function(x) {
FALSE
}
#' @export
tz.yearmonth <- function(x) {
"UTC"
}
# diff.yearmonth <- function(x, lag = 1, differences = 1, ...) {
# out <- diff((year(x) - 1970) * 12 + month(x),
# lag = lag, differences = differences
# )
# structure(out, class = "difftime", units = "months")
# }
#' @rdname tsibble-vctrs
#' @method vec_cast yearmonth
#' @export
vec_cast.yearmonth <- function(x, to, ...) {
UseMethod("vec_cast.yearmonth")
}
#' @export
vec_cast.Date.yearmonth <- function(x, to, ...) {
new_date(x)
}
#' @export
vec_cast.POSIXct.yearmonth <- function(x, to, ...) {
as.POSIXct(new_date(x), ...)
}
#' @export
vec_cast.double.yearmonth <- function(x, to, ...) {
as.double((year(x) - 1970) * 12 + month(x) - 1)
}
#' @export
vec_cast.POSIXlt.yearmonth <- function(x, to, ...) {
as.POSIXlt(new_date(x), ...)
}
#' @export
vec_cast.yearmonth.yearmonth <- function(x, to, ...) {
new_yearmonth(x)
}
#' @export
vec_cast.character.yearmonth <- function(x, to, ...) {
format(x)
}
#' @rdname tsibble-vctrs
#' @method vec_ptype2 yearmonth
#' @export
vec_ptype2.yearmonth <- function(x, y, ...) {
UseMethod("vec_ptype2.yearmonth", y)
}
#' @export
vec_ptype2.yearmonth.POSIXct <- function(x, y, ...) {
new_datetime()
}
#' @export
vec_ptype2.POSIXct.yearmonth <- function(x, y, ...) {
new_datetime()
}
#' @export
vec_ptype2.yearmonth.Date <- function(x, y, ...) {
new_date()
}
#' @export
vec_ptype2.yearmonth.yearmonth <- function(x, y, ...) {
new_yearmonth()
}
#' @export
vec_ptype2.Date.yearmonth <- function(x, y, ...) {
new_date()
}
#' @rdname tsibble-vctrs
#' @method vec_arith yearmonth
#' @export
vec_arith.yearmonth <- function(op, x, y, ...) {
UseMethod("vec_arith.yearmonth", y)
}
#' @method vec_arith.yearmonth default
#' @export
vec_arith.yearmonth.default <- function(op, x, y, ...) {
stop_incompatible_op(op, x, y)
}
#' @method vec_arith.yearmonth numeric
#' @export
vec_arith.yearmonth.numeric <- function(op, x, y, ...) {
if (op == "+") {
new_yearmonth(as_date(x) + period(months = y))
} else if (op == "-") {
new_yearmonth(as_date(x) - period(months = y))
} else {
stop_incompatible_op(op, x, y)
}
}
#' @method vec_arith.yearmonth yearmonth
#' @export
vec_arith.yearmonth.yearmonth <- function(op, x, y, ...) {
if (op == "-") {
as.double(x) - as.double(y)
} else {
stop_incompatible_op(op, x, y)
}
}
#' @method vec_arith.numeric yearmonth
#' @export
vec_arith.numeric.yearmonth <- function(op, x, y, ...) {
if (op == "+") {
yearmonth(period(months = x) + as_date(y))
} else {
stop_incompatible_op(op, x, y)
}
}
#' @method vec_arith.yearmonth MISSING
#' @export
vec_arith.yearmonth.MISSING <- function(op, x, y, ...) {
switch(op,
`-` = x,
`+` = x,
stop_incompatible_op(op, x, y)
)
}
#' @export
format.yearmonth <- function(x, format = "%Y %b", ...) {
format.Date(new_date(x), format = format, ...)
}
#' @rdname tsibble-vctrs
#' @export
obj_print_data.yearmonth <- function(x, ...) {
if (length(x) == 0) return()
print(format(x))
}
#' @export
vec_ptype_abbr.yearmonth <- function(x, ...) {
"mth"
}
#' @export
seq.yearmonth <- function(from, to, by, length.out = NULL, along.with = NULL,
...) {
from <- vec_cast(from, new_date())
if (!is_missing(to)) {
to <- vec_cast(to, new_date())
}
if (is_missing(by)) {
new_yearmonth(seq_date(
from = from, to = to, length.out = length.out,
along.with = along.with, ...
))
} else {
bad_by(by)
by_mth <- paste(by, "month")
new_yearmonth(seq_date(
from = from, to = to, by = by_mth, length.out = length.out,
along.with = along.with, ...
))
}
}
#' @importFrom generics union
#' @export
generics::union
#' @importFrom generics intersect
#' @export
generics::intersect
#' @importFrom generics setdiff
#' @export
generics::setdiff
set_ops <- function(class = "yearmonth", op = "intersect") {
force(class)
force(op)
fun <- switch(op,
"union" = function(x, y, ...) vec_unique(vec_c(x, y)),
"intersect" = function(x, y, ...) vec_slice(x, vec_in(x, y)),
"setdiff" = function(x, y, ...)
vec_unique(if (length(x) || length(y)) x[is.na(vec_match(x, y))] else x)
)
function(x, y, ...) {
abort_if_not(y, class)
fun(x, y, ...)
}
}
#' @export
union.yearmonth <- set_ops("yearmonth", op = "union")
#' @export
intersect.yearmonth <- set_ops("yearmonth", op = "intersect")
#' @export
setdiff.yearmonth <- set_ops("yearmonth", op = "setdiff")
bad_by <- function(by) {
if (!is_bare_numeric(by, n = 1)) {
abort("`by` only takes a numeric.")
}
}
# nocov start
seq_date <- function(from, to, by, length.out = NULL, along.with = NULL, ...) {
if (missing(from)) {
stop("'from' must be specified")
}
if (!inherits(from, "Date")) {
stop("'from' must be a \"Date\" object")
}
if (length(as.Date(from)) != 1L) {
stop("'from' must be of length 1")
}
if (!missing(to)) {
if (!inherits(to, "Date")) {
stop("'to' must be a \"Date\" object")
}
if (length(as.Date(to)) != 1L) {
stop("'to' must be of length 1")
}
}
if (!is.null(along.with)) { # !missing(along.with) in seq.Date
length.out <- length(along.with)
} else if (!is.null(length.out)) {
if (length(length.out) != 1L) {
stop("'length.out' must be of length 1")
}
length.out <- ceiling(length.out)
}
status <- c(!missing(to), !missing(by), !is.null(length.out))
if (sum(status) != 2L) {
stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")
}
if (missing(by)) {
from <- unclass(as.Date(from))
to <- unclass(as.Date(to))
res <- as.double(seq.int(from, to, length.out = length.out))
return(new_date(res))
}
if (length(by) != 1L) {
stop("'by' must be of length 1")
}
valid <- 0L
if (inherits(by, "difftime")) {
by <- switch(attr(by, "units"), secs = 1 / 86400, mins = 1 / 1440,
hours = 1 / 24, days = 1, weeks = 7
) * unclass(by)
} else if (is.character(by)) {
by2 <- strsplit(by, " ", fixed = TRUE)[[1L]]
if (length(by2) > 2L || length(by2) < 1L) {
stop("invalid 'by' string")
}
valid <- pmatch(by2[length(by2)], c(
"days", "weeks",
"months", "quarters", "years"
))
if (is.na(valid)) {
stop("invalid string for 'by'")
}
if (valid <= 2L) {
by <- c(1, 7)[valid]
if (length(by2) == 2L) {
by <- by * as.integer(by2[1L])
}
} else {
by <- if (length(by2) == 2L) {
as.integer(by2[1L])
} else {
1
}
}
} else if (!is.numeric(by)) {
stop("invalid mode for 'by'")
}
if (is.na(by)) {
stop("'by' is NA")
}
if (valid <= 2L) {
from <- unclass(as.Date(from))
if (!is.null(length.out)) {
res <- seq.int(from, by = by, length.out = length.out)
} else {
to0 <- unclass(as.Date(to))
res <- seq.int(0, to0 - from, by) + from
}
} else {
r1 <- as.POSIXlt(from)
if (valid == 5L) {
if (missing(to)) {
yr <- seq.int(r1$year, by = by, length.out = length.out)
} else {
to0 <- as.POSIXlt(to)
yr <- seq.int(r1$year, to0$year, by)
}
r1$year <- yr
res <- as.Date(r1)
} else {
if (valid == 4L) {
by <- by * 3
}
if (missing(to)) {
mon <- seq.int(r1$mon, by = by, length.out = length.out)
}
else {
to0 <- as.POSIXlt(to)
mon <- seq.int(r1$mon, 12 * (to0$year - r1$year) +
to0$mon, by)
}
r1$mon <- mon
res <- as.Date(r1)
}
}
if (!missing(to)) {
to <- as.Date(to)
res <- if (by > 0) {
res[res <= to]
} else {
res[res >= to]
}
}
new_date(as.double(res))
}
# nocov end
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.