1#' @details
2#' `r lifecycle::badge("stable")`
3#' @importFrom lifecycle deprecate_soft expect_deprecated
4#' @import vctrs
5#' @import rlang
6#' @import ellipsis
7#' @aliases hms-package NULL
8"_PACKAGE"
9
10#' @importFrom methods setOldClass
11setOldClass(c("hms", "difftime"))
12
13#' A simple class for storing time-of-day values
14#'
15#' The values are stored as a [difftime] vector with a custom class,
16#' and always with "seconds" as unit for robust coercion to numeric.
17#' Supports construction from time values, coercion to and from
18#' various data types, and formatting.  Can be used as a regular column in a
19#' data frame.
20#'
21#' @name hms
22#' @examples
23#' hms(56, 34, 12)
24#' hms()
25#'
26#' new_hms(as.numeric(1:3))
27#' # Supports numeric only!
28#' try(new_hms(1:3))
29#'
30#' as_hms(1)
31#' as_hms("12:34:56")
32#' as_hms(Sys.time())
33#' as.POSIXct(hms(1))
34#' data.frame(a = hms(1))
35#' d <- data.frame(hours = 1:3)
36#' d$hours <- hms(hours = d$hours)
37#' d
38NULL
39
40# Construction ------------------------------------------------------------
41
42#' hms()
43#'
44#' `hms()` is a high-level constructor that accepts second, minute, hour and day components
45#' as numeric vectors.
46#'
47#' @rdname hms
48#' @details For `hms`, all arguments must have the same length or be
49#'   `NULL`.  Odd combinations (e.g., passing only `seconds` and
50#'   `hours` but not `minutes`) are rejected.
51#' @param seconds,minutes,hours,days Time since midnight. No bounds checking is
52#'   performed.
53#' @export
54hms <- function(seconds = NULL, minutes = NULL, hours = NULL, days = NULL) {
55  args <- list(seconds = seconds, minutes = minutes, hours = hours, days = days)
56  check_args(args)
57  arg_secs <- map2(args, c(1, 60, 3600, 86400), `*`)
58  secs <- reduce(arg_secs[!map_lgl(args, is.null)], `+`)
59  if (is.null(secs)) secs <- numeric()
60
61  new_hms(as.numeric(secs))
62}
63
64#' new_hms()
65#'
66#' `new_hms()` is a low-level constructor that only checks that its input has the correct base type, [numeric].
67#'
68#' @rdname hms
69#' @export
70new_hms <- function(x = numeric()) {
71  vec_assert(x, numeric())
72
73  out <- new_duration(x, units = "secs")
74
75  # no class argument?
76  class(out) <- c("hms", class(out))
77  out
78}
79
80#' is_hms()
81#'
82#' `is_hms()` checks if an object is of class `hms`.
83#'
84#' @rdname hms
85#' @export
86is_hms <- function(x) inherits(x, "hms")
87
88#' Deprecated functions
89#'
90#' @name Deprecated
91NULL
92
93#' Deprecated is.hms()
94#'
95#' `is.hms()` has been replaced by [is_hms()].
96#'
97#' @inheritParams is_hms
98#' @rdname Deprecated
99#' @export
100#' @keywords internal
101is.hms <- function(x) {
102  deprecate_soft("0.5.0", "hms::is.hms()", "hms::is_hms()")
103  is_hms(x)
104}
105
106#' @export
107vec_ptype_abbr.hms <- function(x) {
108  "time"
109}
110
111#' @export
112vec_ptype_full.hms <- function(x) {
113  "time"
114}
115
116# Coercion in -------------------------------------------------------------
117
118#' as_hms()
119#'
120#' `as_hms()` is a generic that supports conversions beyond casting.
121#' The default method forwards to [vec_cast()].
122#'
123#' For arguments of type [POSIXct] and [POSIXlt], `as_hms()` does not perform timezone
124#' conversion.
125#' Use [lubridate::with_tz()] and [lubridate::force_tz()] as necessary.
126#'
127#' @rdname hms
128#' @param x An object.
129#' @export
130as_hms <- function(x, ...) {
131  check_dots_used()
132
133  UseMethod("as_hms")
134}
135
136#' @export
137as_hms.default <- function(x, ...) {
138  vec_cast(x, new_hms())
139}
140
141#' Deprecated as.hms()
142#'
143#' `as.hms()` has been replaced by [as_hms()], which does not have a `tz` argument.
144#' Change the timezone before converting if necessary, e.g. using [lubridate::with_tz()].
145#'
146#' @inheritParams as_hms
147#' @param ... Arguments passed on to further methods.
148#' @rdname Deprecated
149#' @export
150#' @keywords internal
151as.hms <- function(x, ...) {
152  deprecate_soft("0.5.0", "hms::as.hms()", "hms::as_hms()")
153  UseMethod("as.hms", x)
154}
155
156#' @rdname Deprecated
157#' @export
158as.hms.default <- function(x, ...) {
159  as_hms(x)
160}
161
162#' @rdname Deprecated
163#' @param tz The time zone in which to interpret a POSIXt time for extracting
164#'   the time of day.  The default is now the zone of `x` but was `"UTC"`
165#'   for v0.3 and earlier.  The previous behavior can be restored by calling
166#'   `pkgconfig::set_config("hms::default_tz", "UTC")`, see
167#'   [pkgconfig::set_config()].
168#' @export
169#' @importFrom pkgconfig get_config
170as.hms.POSIXt <- function(x, tz = pkgconfig::get_config("hms::default_tz", ""), ...) {
171  time <- as.POSIXlt(x, tz = tz)
172  vec_cast(time, new_hms())
173}
174
175#' @rdname Deprecated
176#' @export
177as.hms.POSIXlt <- function(x, tz = pkgconfig::get_config("hms::default_tz", ""), ...) {
178  # We need to roundtrip via as.POSIXct() to respect the time zone
179  time <- as.POSIXlt(as.POSIXct(x), tz = tz)
180  vec_cast(time, new_hms())
181}
182
183
184# Coercion out ------------------------------------------------------------
185
186#' @rdname hms
187#' @inheritParams base::as.data.frame
188#' @export
189as.POSIXct.hms <- function(x, ...) {
190  vec_cast(x, new_datetime())
191}
192
193#' @rdname hms
194#' @export
195as.POSIXlt.hms <- function(x, ...) {
196  vec_cast(x, as.POSIXlt(new_datetime()))
197}
198
199#' @rdname hms
200#' @export
201as.character.hms <- function(x, ...) {
202  vec_cast(x, character())
203}
204
205format_hms <- function(x) {
206  xx <- decompose(x)
207
208  ifelse(is.na(x), NA_character_, paste0(
209    ifelse(xx$sign, "-", ""),
210    format_hours(xx$hours), ":",
211    format_two_digits(xx$minute_of_hour), ":",
212    format_two_digits(xx$second_of_minute),
213    format_tics(xx$tics)))
214}
215
216
217# Subsetting --------------------------------------------------------------
218
219#' @export
220`[[.hms` <- function(x, ...) {
221  vec_restore(NextMethod(), x)
222}
223
224#' @export
225`[<-.hms` <- function(x, i, value) {
226  if (missing(i)) {
227    i <- TRUE
228  }
229
230  x <- vec_data(x)
231
232  # Workaround for Ops.difftime() implementation for unary minus
233  if (identical(class(value), "numeric")) {
234    attr(value, "units") <- NULL
235  }
236
237  value <- vec_cast(value, new_hms())
238  x[i] <- vec_data(value)
239  new_hms(x)
240}
241
242# Combination -------------------------------------------------------------
243#' @export
244c.hms <- function(x, ...) {
245  # Needed to override c.difftime()
246  vec_c(x, ...)
247}
248
249# Updating ----------------------------------------------------------------
250
251#' @export
252`units<-.hms` <- function(x, value) {
253  if (!identical(value, "secs")) {
254    warning("hms always uses seconds as unit.", call. = FALSE)
255  }
256  x
257}
258
259
260# Output ------------------------------------------------------------------
261
262#' @rdname hms
263#' @export
264format.hms <- function(x, ...) {
265  if (length(x) == 0L) {
266    "hms()"
267  } else {
268    format(as.character(x), justify = "right")
269  }
270}
271
272#' @rdname hms
273#' @export
274print.hms <- function(x, ...) {
275  cat(format(x), sep = "\n")
276  invisible(x)
277}
278