-
Notifications
You must be signed in to change notification settings - Fork 2
/
date.R
107 lines (96 loc) · 2.51 KB
/
date.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
#' Floor Date
#'
#' Coerces vectors to floored Date vectors.
#'
#' @inheritParams params
#' @param x A vector.
#' @param value A date vector.
#' @param origin Origin date.
#'
#' @return A floored Date vector.
#' @family floor
#' @export
#'
#' @examples
#' dtt_date(1L)
#' dtt_date(-1)
#' dtt_date("2000-01-01")
#' as.Date(as.POSIXct("2019-05-01", tz = "Etc/GMT-8"))
#' dtt_date(as.POSIXct("2019-05-01", tz = "Etc/GMT-8"))
#' dtt_date(hms::as_hms("23:59:59"))
#' dtt_date(hms::as_hms("24:00:00"))
dtt_date <- function(x, ...) {
UseMethod("dtt_date")
}
#' @rdname dtt_date
#' @export
`dtt_date<-` <- function(x, value) {
UseMethod("dtt_date<-")
}
#' @describeIn dtt_date Coerce integer vector to a floored Date vector
#' @export
dtt_date.integer <- function(x, origin = as.Date("1970-01-01"), ...) {
chk_unused(...)
as.Date(x, origin = origin)
}
#' @describeIn dtt_date Coerce double vector to a floored Date vector
#' @export
dtt_date.double <- function(x, origin = as.Date("1970-01-01"), ...) {
chk_unused(...)
dtt_date(as.integer(floor(x)), origin = origin)
}
#' @describeIn dtt_date Coerce character vector to a floored Date vector
#' @export
dtt_date.character <- function(x, ...) {
chk_unused(...)
dtt_date(as.Date(x))
}
#' @describeIn dtt_date Coerce Date vector to a floored Date vector
#' @export
dtt_date.Date <- function(x, ...) {
chk_unused(...)
dtt_floor(x)
}
#' @describeIn dtt_date Coerce POSIXct vector to a floored Date vector
#' @export
dtt_date.POSIXct <- function(x, ...) {
chk_unused(...)
as.Date(format(x, "%Y-%m-%d"))
}
#' @describeIn dtt_date Coerce hms vector to a floored Date vector
#' @export
dtt_date.hms <- function(x, ...) {
x <- unclass(x)
attributes(x) <- NULL
x <- as.Date("1970-01-01") + unclass(x) / dtt_units_per_unit()
dtt_floor(x)
}
#' @describeIn dtt_date Set date values for a Date vector
#' @export
`dtt_date<-.Date` <- function(x, value) {
chk_s3_class(value, "Date")
chk_subset(length(value), c(1L, length(x)))
if (!length(x)) {
return(x)
}
value <- dtt_date(value)
if (identical(length(value), 1L)) {
return(rep(value, length(x)))
}
return(value)
}
#' @describeIn dtt_date Set date values for a POSIXct vector
#' @export
`dtt_date<-.POSIXct` <- function(x, value) {
chk_s3_class(value, "Date")
chk_subset(length(value), c(1L, length(x)))
if (!length(x)) {
return(x)
}
tz <- dtt_tz(x)
x <- as.POSIXlt(x, tz = tz)
x$year <- dtt_year(value) - 1900L
x$mon <- dtt_month(value) - 1L
x$mday <- dtt_day(value)
as.POSIXct(format(x), tz = tz)
}