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