hms/0000755000176200001440000000000013205415021011032 5ustar liggesusershms/tests/0000755000176200001440000000000013155736157012220 5ustar liggesusershms/tests/testthat.R0000644000176200001440000000006213155736157014201 0ustar liggesuserslibrary(testthat) library(hms) test_check("hms") hms/tests/testthat/0000755000176200001440000000000013205415021014034 5ustar liggesusershms/tests/testthat/test-coercion.R0000644000176200001440000000255513157020635016755 0ustar liggesuserscontext("coercion") test_that("coercion in", { expect_identical(as.hms(0.5 * 86400), hms(hours = 12)) expect_identical(as.hms(-0.25 * 86400), hms(hours = -6)) expect_hms_equal(as.hms("12:34:56"), hms(56, 34, 12)) expect_hms_equal(as.hms(strptime("12:34:56", format = "%H:%M:%S", tz = "UTC"), tz = "UTC"), hms(56, 34, 12)) expect_hms_equal(as.hms(strptime("12:34:56", format = "%H:%M:%S", tz = "CEST"), tz = "CEST"), hms(56, 34, 12)) expect_hms_equal(as.hms(strptime("12:34:56", format = "%H:%M:%S", tz = "PST8PDT"), tz = "PST8PDT"), hms(56, 34, 12)) now <- Sys.time() now_lt <- as.POSIXlt(now) expect_hms_equal(as.hms(now), hms(now_lt$sec, now_lt$min, now_lt$hour)) expect_hms_equal(as.hms(now_lt), as.hms(now)) expect_error(as.hms(FALSE)) }) test_that("coercion out", { expect_identical(as.character(hms(56, 34, 12)), "12:34:56") expect_identical(as.POSIXlt(hms(hours = 6)), strptime("1970-01-01 06:00:00", format = "%Y-%m-%d %H:%M:%S", tz = "UTC")) expect_identical(as.POSIXct(hms(hours = -6)), strptime("1970-01-01 18:00:00", format = "%Y-%m-%d %H:%M:%S", tz = "UTC") - 86400) df <- data.frame(a = 1:3) df$b <- hms(hours = df$a) expect_identical(df, data.frame(a = 1:3, b = hms(hours = 1:3))) }) hms/tests/testthat/test-colformat.R0000644000176200001440000000114113203156665017135 0ustar liggesuserscontext("pillar") test_that("pillar", { expect_known_pillar_shaft_display( hms(c(-3600, -60, -1, -0.001, 0, 0.001, 1, 60, 3600, NA)), file = "hmss.txt" ) expect_known_pillar_shaft_display( hms(c(-3600000, -3600, -60, -1, 0, 1, 60, 3600, 3600000, NA)), file = "hms.txt" ) expect_known_pillar_shaft_display( hms(c(-3600, -60, 0, 60, 3600, NA)), file = "hm.txt" ) expect_known_pillar_shaft_display( hms(c(-60, -1, 0, 1, 60, NA)), file = "ms.txt" ) expect_known_pillar_shaft_display( hms(c(-60, -1, -0.001, 0, 0.001, 1, 60, NA)), file = "mss.txt" ) }) hms/tests/testthat/test-output.R0000644000176200001440000000402413203156665016512 0ustar liggesuserscontext("output") test_that("output", { expect_identical(format(hms(1:2, minutes = c(0, 0), hours = 3:4)), c("03:00:01", "04:00:02")) expect_identical(format(hms(minutes = 1:-1)), c(" 00:01:00", " 00:00:00", "-00:01:00")) expect_output( expect_identical(print(hms(minutes = 1:2, hours = 3:4)), hms(minutes = 1:2, hours = 3:4)), "03:01:00\n04:02:00", fixed = TRUE) }) test_that("beyond 24 hours (#12)", { expect_identical(format(hms(hours = 23:25)), c("23:00:00", "24:00:00", "25:00:00")) expect_identical(format(hms(hours = 99:101)), c(" 99:00:00", "100:00:00", "101:00:00")) expect_identical(format(hms(hours = c(-99, 100))), c("- 99:00:00", " 100:00:00")) expect_identical(format(hms(hours = c(-100, 99))), c("-100:00:00", " 99:00:00")) }) test_that("fractional seconds (#13)", { expect_identical(format(hms(0.1)), c("00:00:00.1")) expect_identical(format(hms(c(12, 0.3))), c("00:00:12.0", "00:00:00.3")) expect_identical(format(hms(c(0.1, 0.01))), c("00:00:00.10", "00:00:00.01")) expect_identical(format(hms(c(12, 0.3), minutes = c(0, 0), hours = c(345, 6))), c("345:00:12.0", " 06:00:00.3")) expect_identical(format(hms(c(-0.1, 0.1))), c("-00:00:00.1", " 00:00:00.1")) }) test_that("picoseconds (#17)", { expect_identical(format(hms(1e-6)), c("00:00:00.000001")) expect_identical(format(hms(9e-7)), c("00:00:00.000001")) expect_identical(format(hms(4e-7)), c("00:00:00.000000")) expect_identical(format(hms(1e-10)), c("00:00:00.000000")) expect_identical(format(hms(1e-20)), c("00:00:00.000000")) expect_identical(format(hms(c(1, 1e-20))), c("00:00:01.000000", "00:00:00.000000")) }) test_that("NA", { expect_identical(format(hms(NA)), c("NA")) }) hms/tests/testthat/test-round.R0000644000176200001440000000134613155736157016313 0ustar liggesuserscontext("round") test_that("round_hms", { expect_equal(round_hms(parse_hms("12:34:56"), 5), hms(55, 34, 12)) expect_equal(round_hms(parse_hms("12:34:56"), 60), hms(0, 35, 12)) expect_equal(round_hms(hms(0.7), 0.25), hms(0.75)) expect_equal(round_hms(hms(NA), 5), hms(NA)) expect_equal(round_hms(parse_hms(c("12:34:56", NA)), 5), as.hms(c(hms(55, 34, 12), hms(NA)))) }) test_that("trunc_hms", { expect_equal(trunc_hms(parse_hms("12:34:56"), 5), hms(55, 34, 12)) expect_equal(trunc_hms(parse_hms("12:34:56"), 60), hms(0, 34, 12)) expect_equal(trunc_hms(hms(0.7), 0.25), hms(0.5)) expect_equal(trunc_hms(hms(NA), 5), hms(NA)) expect_equal(trunc_hms(parse_hms(c("12:34:56", NA)), 5), as.hms(c(hms(55, 34, 12), hms(NA)))) }) hms/tests/testthat/test-lubridate.R0000644000176200001440000000114213157020635017116 0ustar liggesuserscontext("lubridate") test_that("duration", { skip_if_not_installed("lubridate") expect_identical(lubridate::as.duration(hms(minutes = 1:3)), lubridate::duration(minutes = 1:3)) }) test_that("interval", { skip_if_not_installed("lubridate") timestamp <- Sys.time() expect_identical(lubridate::as.interval(hms(seconds = 2), timestamp), lubridate::interval(timestamp, timestamp + 2)) }) test_that("period", { skip_if_not_installed("lubridate") expect_identical(lubridate::as.period(hms(hours = -1)), lubridate::period(hours = -1)) }) hms/tests/testthat/test-subset.R0000644000176200001440000000102713157020635016452 0ustar liggesuserscontext("subset") test_that("range subsetting keeps class", { expect_identical(hms(1:3)[2], hms(2)) expect_identical(hms(1:3)[2:3], hms(2:3)) }) test_that("range updating keeps class", { x <- hms(1:3) x[2] <- 4 expect_identical(x, hms(c(1,4,3))) x <- hms(1:4) x[2:3] <- 5:6 expect_identical(x, hms(c(1,5,6,4))) }) test_that("index subsetting keeps class", { expect_identical(hms(1:3)[[2]], hms(2)) }) test_that("index updating keeps class", { x <- hms(1:3) x[[2]] <- 4 expect_identical(x, hms(c(1,4,3))) }) hms/tests/testthat/test-parse.R0000644000176200001440000000073613155736157016300 0ustar liggesuserscontext("parse") test_that("parse_hms", { expect_equal(parse_hms("12:34:56"), hms(56, 34, 12)) expect_equal(parse_hms("12:34:56.789"), hms(56.789, 34, 12)) expect_equal(parse_hms(NA), hms(NA)) expect_equal(parse_hms(c("12:34:56", NA)), as.hms(c(hms(56, 34, 12), hms(NA)))) }) test_that("parse_hm", { expect_equal(parse_hm("12:34"), hms(0, 34, 12)) expect_equal(parse_hm(NA), hms(NA)) expect_equal(parse_hm(c("12:34", NA)), as.hms(c(hms(0, 34, 12), hms(NA)))) }) hms/tests/testthat/helper-pillar.R0000644000176200001440000000030213203156665016730 0ustar liggesusersexpect_known_pillar_shaft_display <- function(x, file, width) { object_quo <- rlang::quo(pillar::pillar_shaft(x)) pillar::expect_known_display(!!object_quo, file = file.path("out", file)) } hms/tests/testthat/test-update.R0000644000176200001440000000043013155736157016437 0ustar liggesuserscontext("update") test_that("Can't update units", { x <- hms(minutes = 3) expect_equal(units(x), "secs") expect_warning(units(x) <- "mins", "always uses seconds") expect_equal(units(x), "secs") expect_warning(units(x) <- "secs", NA) expect_equal(units(x), "secs") }) hms/tests/testthat/test-combine.R0000644000176200001440000000076213204566564016577 0ustar liggesuserscontext("combine") test_that("combination keeps class and order", { expect_identical(c(hms(1), hms(2)), hms(1:2)) }) test_that("combination coerces to hms", { expect_identical(c(hms(1), 2), hms(1:2)) if (getRversion() < "3.3") skip("Only for R >= 3.3") expect_identical(c(hms(1), "00:00:02"), hms(1:2)) }) # In R base,`c(as.difftime("20:00:00"), NA)` fails test_that("composition with NA fails", { if (getRversion() < "3.3") skip("Only for R >= 3.3") expect_error(c(hms(1), NA)) }) hms/tests/testthat/test-arith.R0000644000176200001440000000241213155736157016266 0ustar liggesuserscontext("arith") test_that("arithmetics work", { expect_equal(as.Date("2016-03-31") + hms(hours = 1), as.Date("2016-03-31")) expect_equal(as.Date("2016-03-31") + hms(days = -1), as.Date("2016-03-30")) expect_equal(as.POSIXct("2016-03-31") + hms(1), as.POSIXct("2016-03-31 00:00:01")) expect_equal(hms(hours = 1) + as.Date("2016-03-31"), as.Date("2016-03-31")) expect_equal(hms(days = 1) + as.Date("2016-03-31"), as.Date("2016-04-01")) expect_equal(hms(hours = 1) + as.POSIXct("2016-03-31"), as.POSIXct("2016-03-31 01:00:00")) expect_difftime_equal(hms(1) + hms(2), hms(3)) expect_difftime_equal(hms(1) - hms(2), hms(-1)) expect_difftime_equal(2 * hms(1), hms(2)) expect_difftime_equal(hms(hours = 1) / 2, hms(minutes = 30)) }) test_that("component extraction work", { x <- hms(12.3, 45, 23, 1) expect_equal(split_second_of_second(x), 0.3) expect_equal(second_of_minute(x), 12) expect_equal(minute_of_hour(x), 45) expect_equal(hour_of_day(x), 23) expect_equal(days(x), 1) }) test_that("component extraction work for negative times", { x <- -hms(12.3, 45, 23, 1) expect_equal(split_second_of_second(x), 0.3) expect_equal(second_of_minute(x), 12) expect_equal(minute_of_hour(x), 45) expect_equal(hour_of_day(x), 23) expect_equal(days(x), -1) }) hms/tests/testthat/out/0000755000176200001440000000000013203156665014661 5ustar liggesusershms/tests/testthat/out/hms.txt0000644000176200001440000000104613203156665016212 0ustar liggesusers-1000:00:00 - 01:00:00 - 00:01:00 - 00:00:01  00:00:00  00:00:01  00:01:00 01:00:00 1000:00:00 NA hms/tests/testthat/out/hmss.txt0000644000176200001440000000122413203156665016373 0ustar liggesusers-01:00:00.000 -00:01:00.000 -00:00:01.000 -00:00:00.001 00:00:00.000 00:00:00.001 00:00:01.000 00:01:00.000 01:00:00.000 NA hms/tests/testthat/out/ms.txt0000644000176200001440000000037013203156665016041 0ustar liggesusers-01'00" -00'01" 00'00" 00'01" 01'00" NA hms/tests/testthat/out/hm.txt0000644000176200001440000000030013203156665016017 0ustar liggesusers-01:00 -00:01 00:00 00:01 01:00 NA hms/tests/testthat/out/mss.txt0000644000176200001440000000066413203156665016232 0ustar liggesusers-01'00.000" -00'01.000" -00'00.001" 00'00.000" 00'00.001" 00'01.000" 01'00.000" NA hms/tests/testthat/test-construct.R0000644000176200001440000000255013204566564017204 0ustar liggesuserscontext("construct") test_that("constructor", { expect_identical(hms(1:3, 2:4, 3:5, 4:6), hms(seconds = 1:3 + 2:4 * 60 + 3:5 * 3600 + 4:6 * 86400)) expect_identical(hms(-1, 1), hms(59)) expect_identical(hms(3600), hms(hours = 1)) expect_equal(length(hms(1)), 1L) expect_true(is.hms(hms(1))) expect_is(hms(1), "difftime") expect_identical(as.numeric(hms(1)), 1) expect_identical(as.difftime(hms(1)), hms(1)) expect_identical(units(as.hms(as.difftime(1, units = "mins"))), "secs") expect_identical(as.hms(hms(1)), hms(1)) }) test_that("zero length (#35)", { expect_equal(length(hms()), 0L) expect_true(is.hms(hms())) expect_is(hms(), "difftime") expect_identical(as.numeric(hms()), numeric()) expect_identical(as.difftime(hms()), hms()) expect_identical(hms(), hms(seconds = numeric())) expect_identical(hms(), hms(minutes = numeric())) expect_identical(hms(), hms(hours = numeric())) expect_identical(hms(), hms(days = numeric())) expect_identical(hms(), as.hms(numeric())) }) test_that("bad input", { expect_error(hms(hours = 1, seconds = 3), "only") expect_error(hms(minutes = 1, days = 3), "only") expect_error(hms(minutes = 1, hours = 2:3), "same length or be NULL") expect_error(hms(seconds = 1:5, minutes = 6:10, hours = 11:17), "same length or be NULL") expect_error(hms("05:00"), "must be numeric") }) hms/tests/testthat/helper-compare.R0000644000176200001440000000044013155736157017104 0ustar liggesusersexpect_hms_equal <- function(x, y) { expect_is(x, "hms") expect_is(y, "hms") expect_equal(as.numeric(x), as.numeric(y)) } expect_difftime_equal <- function(x, y) { expect_is(x, "difftime") expect_is(y, "difftime") expect_equal(as.numeric(as.hms(x)), as.numeric(as.hms(y))) } hms/NAMESPACE0000644000176200001440000000112313205250155012253 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("[[",hms) S3method("units<-",hms) S3method(as.POSIXct,hms) S3method(as.POSIXlt,hms) S3method(as.character,hms) S3method(as.data.frame,hms) S3method(as.hms,POSIXlt) S3method(as.hms,POSIXt) S3method(as.hms,character) S3method(as.hms,default) S3method(as.hms,difftime) S3method(as.hms,numeric) S3method(c,hms) S3method(format,hms) S3method(print,hms) export(as.hms) export(hms) export(is.hms) export(parse_hm) export(parse_hms) export(round_hms) export(trunc_hms) import(rlang) importFrom(methods,setOldClass) importFrom(pkgconfig,get_config) hms/NEWS.md0000644000176200001440000000551513205250141012136 0ustar liggesusers## hms 0.4.0 (2017-11-16) ### Breaking changes - `as.hms.POSIXt()` now defaults to the current time zone, the previous default was `"UTC"` and can be restored by calling `pkgconfig::set_config("hms::default_tz", "UTC")`. ### New features - Pillar support, will display `hms` columns in tibbles in color on terminals that support it (#43). - New `round_hms()` and `trunc_hms()` for rounding or truncating to a given multiple of seconds (#31). - New `parse_hms()` and `parse_hm()` to parse strings in "HH:MM:SS" and "HH:MM" formats (#30). - `as.hms.POSIXt()` gains `tz` argument, default `"UTC"` (#28). - `as.hms.character()` and `parse_hms()` accept fractional seconds (#33). ### Bug fixes - `hms()` now works correctly if all four components (days, hours, minutes, seconds) are passed (#49). - `hms()` creates a zero-length object of class `hms` that prints as `"hms()"`. - `hms(integer())` and `as.hms(integer())` both work and are identical to `hms()`. - Values with durations of over 10000 hours are now printed correctly (#48). - `c()` now returns a hms (#41, @qgeissmann). ### Documentation and error messages - Fix and enhance examples in `?hms`. - Documentation is in Markdown format now. - Improved error message if calling `hms()` with a character argument (#29). # hms 0.3 (2016-11-22) - Fix `lubridate` test for compatibility with 1.6.0 (#23, @vspinu). - NA values are formatted as `NA` (#22). # hms 0.2 (2016-06-17) Minor fixes and improvements. - Subsetting keeps `hms` class (#16). - `format.hms()` right-justifies the output by padding with spaces from the left, `as.character.hms()` remains unchanged. - Times larger than 24 hours or with split seconds are now formatted correctly (#12, #13). - Sub-second part is printed with up to six digits, for even smaller values trailing zeros are shown (#17). # hms 0.1 (2016-04-30) First CRAN release. - Values are stored as a numeric vector that contains the number of seconds since midnight. - Inherits from `difftime` class. - Updating units is a no-op, anything different from `"secs"` issues a warning. - Supports construction from time values, coercion to and from various data types, and formatting. - Conversion from numeric treats input as seconds. - Negative times are formatted with a leading `-`. - Can be used as a regular column in a data frame. - Full test coverage. - Test for arithmetic with `Date`, `POSIXt` and `hms` classes. - Test basic compatibility with `lubridate` package (#5). - Interface: - `hms()` (with rigorous argument checks) - `as.hms()` for `character`, `numeric`, `POSIXct` and `POSIXlt` - `as.xxx.hms()` for `character`, `numeric` (implicitly), `POSIXct` and `POSIXlt` - `is.hms()` - `as.data.frame.hms()` (forwards to `as.data.frame.difftime()`) - `format.hms()` - `print.hms()` (returns unchanged input invisibly) hms/R/0000755000176200001440000000000013205250155011240 5ustar liggesusershms/R/round.R0000644000176200001440000000123613155736157012533 0ustar liggesusers#' Round or truncate to a multiple of seconds #' #' Convenience functions to round or truncate to a multiple of seconds. #' @param x A vector of class [hms] #' @param secs Multiple of seconds, a positive numeric. Values less than one #' are supported #' @return The input, rounded or truncated to the nearest multiple of `secs` #' @export #' @examples #' round_hms(as.hms("12:34:56"), 5) #' round_hms(as.hms("12:34:56"), 60) round_hms <- function(x, secs) { as.hms(round(as.numeric(x) / secs) * secs) } #' @rdname round_hms #' @export #' @examples #' trunc_hms(as.hms("12:34:56"), 60) trunc_hms <- function(x, secs) { as.hms(trunc(as.numeric(x) / secs) * secs) } hms/R/arith.R0000644000176200001440000000202113203156665012476 0ustar liggesusersSECONDS_PER_MINUTE <- 60 MINUTES_PER_HOUR <- 60 HOURS_PER_DAY <- 24 SECONDS_PER_HOUR <- MINUTES_PER_HOUR * SECONDS_PER_MINUTE SECONDS_PER_DAY <- HOURS_PER_DAY * SECONDS_PER_HOUR days <- function(x) { trunc(as.numeric(x) / SECONDS_PER_DAY) } hours <- function(x) { trunc(as.numeric(x) / SECONDS_PER_HOUR) } hour_of_day <- function(x) { abs(hours(x) - days(x) * HOURS_PER_DAY) } minutes <- function(x) { trunc(as.numeric(x) / SECONDS_PER_MINUTE) } minute_of_hour <- function(x) { abs(minutes(x) - hours(x) * MINUTES_PER_HOUR) } seconds <- function(x) { trunc(as.numeric(x)) } second_of_minute <- function(x) { abs(seconds(x) - minutes(x) * SECONDS_PER_MINUTE) } split_seconds <- function(x) { as.numeric(x) } split_second_of_second <- function(x) { abs(split_seconds(x) - seconds(x)) } decompose <- function(x) { list( sign = x < 0 & !is.na(x), hours = abs(hours(x)), minute_of_hour = minute_of_hour(x), second_of_minute = second_of_minute(x), split_seconds = split_second_of_second(x) ) } hms/R/hms.R0000644000176200001440000001103713205250155012154 0ustar liggesusers#' @import rlang #' @importFrom methods setOldClass setOldClass(c("hms", "difftime")) #' A simple class for storing time-of-day values #' #' The values are stored as a [difftime] vector with a custom class, #' and always with "seconds" as unit for robust coercion to numeric. #' Supports construction from time values, coercion to and from #' various data types, and formatting. Can be used as a regular column in a #' data frame. #' #' @name hms #' @examples #' hms(56, 34, 12) #' hms() #' as.hms(1) #' as.hms("12:34:56") #' as.hms(Sys.time()) #' as.POSIXct(hms(1)) #' data.frame(a = hms(1)) #' d <- data.frame(hours = 1:3) #' d$hours <- hms(hours = d$hours) #' d NULL # Construction ------------------------------------------------------------ #' @rdname hms #' @details For `hms`, all arguments must have the same length or be #' `NULL`. Odd combinations (e.g., passing only `seconds` and #' `hours` but not `minutes`) are rejected. #' @param seconds,minutes,hours,days Time since midnight. No bounds checking is #' performed. #' @export hms <- function(seconds = NULL, minutes = NULL, hours = NULL, days = NULL) { args <- list(seconds = seconds, minutes = minutes, hours = hours, days = days) check_args(args) arg_secs <- map2(args, c(1, 60, 3600, 86400), `*`) secs <- reduce(arg_secs[!map_lgl(args, is.null)], `+`) if (is.null(secs)) secs <- numeric() as.hms(as.difftime(secs, units = "secs")) } #' @rdname hms #' @export is.hms <- function(x) inherits(x, "hms") # Coercion in ------------------------------------------------------------- #' @rdname hms #' @param x An object. #' @param ... Arguments passed on to further methods. #' @export as.hms <- function(x, ...) UseMethod("as.hms", x) #' @rdname hms #' @export as.hms.default <- function(x, ...) { stop("Can't convert object of class ", paste(class(x), collapse = ", "), " to hms.", call. = FALSE) } #' @rdname hms #' @export as.hms.difftime <- function(x, ...) { units(x) <- "secs" structure(x, class = unique(c("hms", class(x)))) } #' @rdname hms #' @export as.hms.numeric <- function(x, ...) hms(seconds = x) #' @rdname hms #' @export as.hms.character <- function(x, ...) { parse_hms(x) } #' @rdname hms #' @param tz The time zone in which to interpret a POSIXt time for extracting #' the time of day. The default is now the zone of `x` but was `"UTC"` #' for v0.3 and earlier. The previous behavior can be restored by calling #' `pkgconfig::set_config("hms::default_tz", "UTC")`, see #' [pkgconfig::set_config()]. #' @export #' @importFrom pkgconfig get_config as.hms.POSIXt <- function(x, tz = pkgconfig::get_config("hms::default_tz", ""), ...) { time <- as.POSIXlt(x, tz = tz) hms(time$sec, time$min, time$hour) } #' @rdname hms #' @export as.hms.POSIXlt <- function(x, tz = pkgconfig::get_config("hms::default_tz", ""), ...) { # We need to roundtrip via as.POSIXct() to respect the time zone as.hms(as.POSIXct(x), tz = tz, ...) } # Coercion out ------------------------------------------------------------ #' @rdname hms #' @export as.POSIXct.hms <- function(x, ...) { structure(as.numeric(x), tzone = "UTC", class = c("POSIXct", "POSIXt")) } #' @rdname hms #' @export as.POSIXlt.hms <- function(x, ...) { as.POSIXlt(as.POSIXct(x, ...), ...) } #' @rdname hms #' @export as.character.hms <- function(x, ...) { xx <- decompose(x) ifelse(is.na(x), "NA", paste0( ifelse(xx$sign, "-", ""), format_hours(xx$hours), ":", format_two_digits(xx$minute_of_hour), ":", format_two_digits(xx$second_of_minute), format_split_seconds(xx$split_seconds))) } #' @rdname hms #' @inheritParams base::as.data.frame #' @param nm Name of column in new data frame #' @export as.data.frame.hms <- forward_to(as.data.frame.difftime) # Subsetting -------------------------------------------------------------- #' @export `[[.hms` <- function(x, ...) { hms(NextMethod()) } # Combination ------------------------------------------------------------- #' @export c.hms <- function(x, ...) { as.hms(NextMethod()) } # Updating ---------------------------------------------------------------- #' @export `units<-.hms` <- function(x, value) { if (!identical(value, "secs")) { warning("hms always uses seconds as unit.", call. = FALSE) } x } # Output ------------------------------------------------------------------ #' @rdname hms #' @export format.hms <- function(x, ...) { if (length(x) == 0L) { "hms()" } else { format(as.character(x), justify = "right") } } #' @rdname hms #' @export print.hms <- function(x, ...) { cat(format(x), sep = "\n") invisible(x) } hms/R/aaa-tools.R0000644000176200001440000000057013155736157013264 0ustar liggesusers# nocov start forward_to <- function(f, envir = parent.frame()) { f_fmls <- formals(f) f_called_fmls <- stats::setNames(lapply(names(f_fmls), as.symbol), names(f_fmls)) f_call <- as.call(c(substitute(f), f_called_fmls)) f_ret <- eval(bquote( function() { .(f_call) } )) formals(f_ret) <- f_fmls environment(f_ret) <- envir f_ret } # nocov end hms/R/pillar.R0000644000176200001440000000371113203156665012661 0ustar liggesusers# Dynamically exported, see zzz.R pillar_shaft.hms <- function(x, ...) { data <- rep(NA_character_, length(x)) xx <- decompose(x) highlight_hours <- xx$hours > 0 highlighted <- highlight_hours highlight_minutes <- !highlighted & xx$minute_of_hour > 0 highlighted <- highlighted | highlight_minutes highlight_seconds <- !highlighted & xx$second_of_minute > 0 highlighted <- highlighted | highlight_seconds highlight_split_seconds <- !highlighted & xx$split_seconds > 0 need_split_seconds <- any(highlight_split_seconds, na.rm = TRUE) need_seconds <- need_split_seconds || any(highlight_seconds, na.rm = TRUE) need_hours <- any(highlight_hours, na.rm = TRUE) need_sign <- any(xx$sign) if (need_hours) { data_seconds <- paste0( if (need_sign) ifelse(xx$sign, "-", " ") else "", pillar::style_num(format_hours(xx$hours), xx$sign, highlight_hours), pillar::style_subtle(":"), pillar::style_num(format_two_digits(xx$minute_of_hour), xx$sign, highlight_minutes), if (need_seconds) paste0( pillar::style_subtle(":"), pillar::style_num(format_two_digits(xx$second_of_minute), xx$sign, highlight_seconds) ) ) data <- paste0( data_seconds, pillar::style_num(format_split_seconds(xx$split_seconds), xx$sign, highlight_split_seconds) ) } else { data_seconds <- paste0( if (need_sign) ifelse(xx$sign, "-", " ") else "", pillar::style_num(format_two_digits(xx$minute_of_hour), xx$sign, highlight_minutes), pillar::style_subtle("'"), pillar::style_num(format_two_digits(xx$second_of_minute), xx$sign, highlight_seconds) ) data <- paste0( data_seconds, pillar::style_num(format_split_seconds(xx$split_seconds), xx$sign, highlight_split_seconds), pillar::style_subtle('"') ) } na_indent <- crayon::col_nchar(data_seconds[1], type = "width") - 2L data[is.na(x)] <- NA pillar::new_pillar_shaft_simple(data, na_indent = na_indent) } hms/R/format.R0000644000176200001440000000057713204566564012701 0ustar liggesusersformat_hours <- function(x) { format(format_two_digits(x), justify = "right") } format_two_digits <- function(x) { formatC(x, format = "f", digits = 0, width = 2, flag = "0") } format_split_seconds <- function(x) { out <- format(x, scientific = FALSE) digits <- max(min(max(nchar(out) - 2), 6), 0) out <- formatC(x, format = "f", digits = digits) gsub("^0", "", out) } hms/R/parse.R0000644000176200001440000000124313155736157012514 0ustar liggesusers#' Parsing hms values #' #' These functions convert character vectors to objects of the [hms] class. #' `NA` values are supported. #' #' `parse_hms()` accepts values of the form `"HH:MM:SS"`, with optional #' fractional seconds. #' @param x A character vector #' @export #' @examples #' parse_hms("12:34:56") #' parse_hms("12:34:56.789") parse_hms <- function(x) { as.hms(as.difftime(as.character(x), format = "%H:%M:%OS", units = "secs")) } #' @rdname parse_hms #' @details `parse_hm()` accepts values of the form `"HH:MM"`. #' @export #' @examples #' parse_hm("12:34") parse_hm <- function(x) { as.hms(as.difftime(as.character(x), format = "%H:%M", units = "secs")) } hms/R/compat-purrr.R0000644000176200001440000000723413204566564014041 0ustar liggesusers# nocov start - compat-purrr (last updated: rlang 0.1.9000) # This file serves as a reference for compatibility functions for # purrr. They are not drop-in replacements but allow a similar style # of programming. This is useful in cases where purrr is too heavy a # package to depend on. Please find the most recent version in rlang's # repository. map <- function(.x, .f, ...) { lapply(.x, .f, ...) } map_mold <- function(.x, .f, .mold, ...) { out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) names(out) <- names(.x) out } map_lgl <- function(.x, .f, ...) { map_mold(.x, .f, logical(1), ...) } map_int <- function(.x, .f, ...) { map_mold(.x, .f, integer(1), ...) } map_dbl <- function(.x, .f, ...) { map_mold(.x, .f, double(1), ...) } map_chr <- function(.x, .f, ...) { map_mold(.x, .f, character(1), ...) } map_cpl <- function(.x, .f, ...) { map_mold(.x, .f, complex(1), ...) } pluck <- function(.x, .f) { map(.x, `[[`, .f) } pluck_lgl <- function(.x, .f) { map_lgl(.x, `[[`, .f) } pluck_int <- function(.x, .f) { map_int(.x, `[[`, .f) } pluck_dbl <- function(.x, .f) { map_dbl(.x, `[[`, .f) } pluck_chr <- function(.x, .f) { map_chr(.x, `[[`, .f) } pluck_cpl <- function(.x, .f) { map_cpl(.x, `[[`, .f) } map2 <- function(.x, .y, .f, ...) { Map(.f, .x, .y, ...) } map2_lgl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "logical") } map2_int <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "integer") } map2_dbl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "double") } map2_chr <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "character") } map2_cpl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "complex") } args_recycle <- function(args) { lengths <- map_int(args, length) n <- max(lengths) stopifnot(all(lengths == 1L | lengths == n)) to_recycle <- lengths == 1L args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) args } pmap <- function(.l, .f, ...) { args <- args_recycle(.l) do.call("mapply", c( FUN = list(quote(.f)), args, MoreArgs = quote(list(...)), SIMPLIFY = FALSE, USE.NAMES = FALSE )) } probe <- function(.x, .p, ...) { if (is_logical(.p)) { stopifnot(length(.p) == length(.x)) .p } else { map_lgl(.x, .p, ...) } } keep <- function(.x, .f, ...) { .x[probe(.x, .f, ...)] } discard <- function(.x, .p, ...) { sel <- probe(.x, .p, ...) .x[is.na(sel) | !sel] } map_if <- function(.x, .p, .f, ...) { matches <- probe(.x, .p) .x[matches] <- map(.x[matches], .f, ...) .x } compact <- function(.x) { Filter(length, .x) } transpose <- function(.l) { inner_names <- names(.l[[1]]) if (is.null(inner_names)) { fields <- seq_along(.l[[1]]) } else { fields <- set_names(inner_names) } map(fields, function(i) { map(.l, .subset2, i) }) } every <- function(.x, .p, ...) { for (i in seq_along(.x)) { if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) } TRUE } some <- function(.x, .p, ...) { for (i in seq_along(.x)) { if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) } FALSE } negate <- function(.p) { function(...) !.p(...) } reduce <- function(.x, .f, ..., .init) { f <- function(x, y) .f(x, y, ...) Reduce(f, .x, init = .init) } reduce_right <- function(.x, .f, ..., .init) { f <- function(x, y) .f(y, x, ...) Reduce(f, .x, init = .init, right = TRUE) } accumulate <- function(.x, .f, ..., .init) { f <- function(x, y) .f(x, y, ...) Reduce(f, .x, init = .init, accumulate = TRUE) } accumulate_right <- function(.x, .f, ..., .init) { f <- function(x, y) .f(y, x, ...) Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) } # nocov end hms/R/args.R0000644000176200001440000000135613204566564012341 0ustar liggesuserscheck_args <- function(args) { is_null <- map_lgl(args, is.null) if (all(is_null)) return() valid <- map_lgl(args[!is_null], is_numeric_or_na) if (!all(valid)) { stop("All arguments must be numeric or NA", call. = FALSE) } if (!all(diff(which(!is_null)) == 1L)) { stop("Can't pass only ", paste(names(is_null)[!is_null], collapse = ", "), " to hms().", call. = FALSE) } lengths <- map_int(args[!is_null], length) if (length(unique(lengths)) > 1L) { stop("All arguments to hms() must have the same length or be NULL. Found ", paste0("length(", names(lengths), ") = ", lengths, collapse = ", "), ".", call. = FALSE) } } is_numeric_or_na <- function(x) { is.numeric(x) || all(is.na(x)) } hms/R/zzz.R0000644000176200001440000000145713203156665012240 0ustar liggesusers# nocov start .onLoad <- function(...) { register_s3_method("pillar", "pillar_shaft", "hms") invisible() } register_s3_method <- function(pkg, generic, class, fun = NULL) { stopifnot(is.character(pkg), length(pkg) == 1) stopifnot(is.character(generic), length(generic) == 1) stopifnot(is.character(class), length(class) == 1) if (is.null(fun)) { fun <- get(paste0(generic, ".", class), envir = parent.frame()) } else { stopifnot(is.function(fun)) } if (pkg %in% loadedNamespaces()) { registerS3method(generic, class, fun, envir = asNamespace(pkg)) } # Always register hook in case package is later unloaded & reloaded setHook( packageEvent(pkg, "onLoad"), function(...) { registerS3method(generic, class, fun, envir = asNamespace(pkg)) } ) } # nocov end hms/README.md0000644000176200001440000000305413205250141012313 0ustar liggesusers hms === [![Travis-CI Build Status](https://travis-ci.org/tidyverse/hms.svg?branch=master)](https://travis-ci.org/tidyverse/hms) [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/tidyverse/hms?branch=master&svg=true)](https://ci.appveyor.com/project/tidyverse/hms) [![codecov](https://codecov.io/gh/tidyverse/hms/branch/master/graph/badge.svg)](https://codecov.io/gh/tidyverse/hms) [![CRAN\_Status\_Badge](http://www.r-pkg.org/badges/version/hms)](https://cran.r-project.org/package=hms) A simple class for storing durations or time-of-day values and displaying them in the hh:mm:ss format. Intended to simplify data exchange with databases, spreadsheets, and other data sources. The values are stored as a numeric vector that contains the number of seconds since midnight. Supports construction from time values, coercion to and from various data types, and formatting, based on the `difftime` class. Can be used in a data frame. Compared to `POSIXct`, no date is stored, although the values can exceed the 24-hour boundary or be negative. By default, fractional seconds up to a microsecond are displayed. ``` r library(hms) hms(56, 34, 12) #> 12:34:56 as.hms(1) #> 00:00:01 as.hms("12:34:56") #> 12:34:56 as.hms(Sys.time()) #> 14:41:28.004544 as.POSIXct(hms(1)) #> [1] "1970-01-01 00:00:01 UTC" data.frame(hours = 1:3, hms = hms(hours = 1:3)) #> hours hms #> 1 1 01:00:00 #> 2 2 02:00:00 #> 3 3 03:00:00 ``` Install the package from GitHub: ``` r # install.packages("devtools") devtools::install_github("tidyverse/hms") ``` hms/MD50000644000176200001440000000364713205415021011354 0ustar liggesusers7feaecc83f2460071b5aa3a1c9c4b933 *DESCRIPTION 1113606c0b5e64437766950b624a4afc *NAMESPACE f814ae2a18aa038b75d965609e252ffa *NEWS.md fcdf13180407d2fdf40bd661731c2c17 *R/aaa-tools.R 1fee82e810be4583b57360d2f66e1ee3 *R/args.R 7df8b329ec567d5034a611c80b293bae *R/arith.R feaa904f11d6970ddbc1057a30cf6610 *R/compat-purrr.R e9ffa388353c6308807e460f5d305d68 *R/format.R 0008f91aa0f29daab622a07cd515406a *R/hms.R c494e482c2c2e9ecb501cb7c1c96c904 *R/parse.R f7f458c6052378720f7924e92a426bae *R/pillar.R 431e1aca642539fad198d2f1773a25a6 *R/round.R 564e931b9db52faf3090415a10a62096 *R/zzz.R 3ceda9573d7cfddc5abc01a9c424f8fa *README.md 6229c2a0e885be9f4c43e0653b170860 *man/hms.Rd 47436ae731f3fb89b03f7738b38c07df *man/parse_hms.Rd 9c9a480061f0b21e078fa4ad07c686d6 *man/round_hms.Rd 929afdb21c50685048246bdc5d82207d *tests/testthat.R fc7098abdba1003efcde210eced441ac *tests/testthat/helper-compare.R 9e06811acc259fc01016555a8d6c43fa *tests/testthat/helper-pillar.R e62b16d4a6b54887a2d796f01d6be2a9 *tests/testthat/out/hm.txt d4004d7ed8d684f185525e8f95d2854a *tests/testthat/out/hms.txt e0eb8d7ee8eeee4b1a6e4d050944e182 *tests/testthat/out/hmss.txt 80e943c2e942458a82800a7ae74b4c70 *tests/testthat/out/ms.txt 79f4dbf41ce81791ddcf6d8602c4edb2 *tests/testthat/out/mss.txt baa00de5b6dad9da9a13212b4dfa0da0 *tests/testthat/test-arith.R 6bd9510a73ac0fdbc3a29fdba7ce3db2 *tests/testthat/test-coercion.R 888229c88d533dd8aa088dc432c3b6b7 *tests/testthat/test-colformat.R f163345c83326e50f8ec79f8a8e88436 *tests/testthat/test-combine.R d520e015b08a6218f62bd92f8fe480c2 *tests/testthat/test-construct.R 8a0858c5e546d54f7719e77a7940b62a *tests/testthat/test-lubridate.R f3d822c260d27441657068d6523a25cc *tests/testthat/test-output.R 3a9c090f1e3f948fb1d699341d036a0f *tests/testthat/test-parse.R f03c4370a8ed3eb16b66f8ff45140475 *tests/testthat/test-round.R 765c3591c7471688d7b53a8fa47bdddc *tests/testthat/test-subset.R 36082171f366b616c4004a919542871c *tests/testthat/test-update.R hms/DESCRIPTION0000644000176200001440000000145513205415021012545 0ustar liggesusersPackage: hms Title: Pretty Time of Day Date: 2017-11-16 Version: 0.4.0 Authors@R: c( person("Kirill", "Müller", role = c("aut", "cre"), email = "krlmlr+r@mailbox.org"), person("The R Consortium", role = "cph") ) Description: Implements an S3 class for storing and formatting time-of-day values, based on the 'difftime' class. Imports: methods, pkgconfig, rlang Suggests: crayon, lubridate, pillar, testthat License: GPL-3 Encoding: UTF-8 LazyData: true URL: https://github.com/tidyverse/hms BugReports: https://github.com/tidyverse/hms/issues RoxygenNote: 6.0.1 NeedsCompilation: no Packaged: 2017-11-22 10:27:35 UTC; muelleki Author: Kirill Müller [aut, cre], The R Consortium [cph] Maintainer: Kirill Müller Repository: CRAN Date/Publication: 2017-11-23 00:45:05 UTC hms/man/0000755000176200001440000000000013155736157011631 5ustar liggesusershms/man/hms.Rd0000644000176200001440000000563413155736157012717 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hms.R \name{hms} \alias{hms} \alias{hms} \alias{is.hms} \alias{as.hms} \alias{as.hms.default} \alias{as.hms.difftime} \alias{as.hms.numeric} \alias{as.hms.character} \alias{as.hms.POSIXt} \alias{as.hms.POSIXlt} \alias{as.POSIXct.hms} \alias{as.POSIXlt.hms} \alias{as.character.hms} \alias{as.data.frame.hms} \alias{format.hms} \alias{print.hms} \title{A simple class for storing time-of-day values} \usage{ hms(seconds = NULL, minutes = NULL, hours = NULL, days = NULL) is.hms(x) as.hms(x, ...) \method{as.hms}{default}(x, ...) \method{as.hms}{difftime}(x, ...) \method{as.hms}{numeric}(x, ...) \method{as.hms}{character}(x, ...) \method{as.hms}{POSIXt}(x, tz = pkgconfig::get_config("hms::default_tz", ""), ...) \method{as.hms}{POSIXlt}(x, tz = pkgconfig::get_config("hms::default_tz", ""), ...) \method{as.POSIXct}{hms}(x, ...) \method{as.POSIXlt}{hms}(x, ...) \method{as.character}{hms}(x, ...) \method{as.data.frame}{hms}(x, row.names = NULL, optional = FALSE, ..., nm = paste(deparse(substitute(x), width.cutoff = 500L), collapse = " ")) \method{format}{hms}(x, ...) \method{print}{hms}(x, ...) } \arguments{ \item{seconds, minutes, hours, days}{Time since midnight. No bounds checking is performed.} \item{x}{An object.} \item{...}{Arguments passed on to further methods.} \item{tz}{The time zone in which to interpret a POSIXt time for extracting the time of day. The default is now the zone of \code{x} but was \code{"UTC"} for v0.3 and earlier. The previous behavior can be restored by calling \code{pkgconfig::set_config("hms::default_tz", "UTC")}, see \code{\link[pkgconfig:set_config]{pkgconfig::set_config()}}.} \item{row.names}{\code{NULL} or a character vector giving the row names for the data frame. Missing values are not allowed.} \item{optional}{logical. If \code{TRUE}, setting row names and converting column names (to syntactic names: see \code{\link{make.names}}) is optional. Note that all of \R's \pkg{base} package \code{as.data.frame()} methods use \code{optional} only for column names treatment, basically with the meaning of \code{\link{data.frame}(*, check.names = !optional)}.} \item{nm}{Name of column in new data frame} } \description{ The values are stored as a \link{difftime} vector with a custom class, and always with "seconds" as unit for robust coercion to numeric. Supports construction from time values, coercion to and from various data types, and formatting. Can be used as a regular column in a data frame. } \details{ For \code{hms}, all arguments must have the same length or be \code{NULL}. Odd combinations (e.g., passing only \code{seconds} and \code{hours} but not \code{minutes}) are rejected. } \examples{ hms(56, 34, 12) hms() as.hms(1) as.hms("12:34:56") as.hms(Sys.time()) as.POSIXct(hms(1)) data.frame(a = hms(1)) d <- data.frame(hours = 1:3) d$hours <- hms(hours = d$hours) d } hms/man/parse_hms.Rd0000644000176200001440000000115613155736157014104 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/parse.R \name{parse_hms} \alias{parse_hms} \alias{parse_hm} \title{Parsing hms values} \usage{ parse_hms(x) parse_hm(x) } \arguments{ \item{x}{A character vector} } \description{ These functions convert character vectors to objects of the \link{hms} class. \code{NA} values are supported. } \details{ \code{parse_hms()} accepts values of the form \code{"HH:MM:SS"}, with optional fractional seconds. \code{parse_hm()} accepts values of the form \code{"HH:MM"}. } \examples{ parse_hms("12:34:56") parse_hms("12:34:56.789") parse_hm("12:34") } hms/man/round_hms.Rd0000644000176200001440000000122613155736157014117 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/round.R \name{round_hms} \alias{round_hms} \alias{trunc_hms} \title{Round or truncate to a multiple of seconds} \usage{ round_hms(x, secs) trunc_hms(x, secs) } \arguments{ \item{x}{A vector of class \link{hms}} \item{secs}{Multiple of seconds, a positive numeric. Values less than one are supported} } \value{ The input, rounded or truncated to the nearest multiple of \code{secs} } \description{ Convenience functions to round or truncate to a multiple of seconds. } \examples{ round_hms(as.hms("12:34:56"), 5) round_hms(as.hms("12:34:56"), 60) trunc_hms(as.hms("12:34:56"), 60) }