From ae4f3a92c5309a0aa695055a7711a40c9d87b400 Mon Sep 17 00:00:00 2001 From: Daniel Vartanian Date: Tue, 25 May 2021 07:02:53 -0300 Subject: [PATCH] Transform `clock_roll()` to an internal S3 generic --- NAMESPACE | 4 ++ R/utils-clock_roll.R | 59 ++++++++++++++++++++++++++ R/utils.R | 44 ++++--------------- tests/testthat/test-utils-clock_roll.R | 45 ++++++++++++++++++++ tests/testthat/test-utils.R | 42 +++++------------- 5 files changed, 127 insertions(+), 67 deletions(-) create mode 100644 R/utils-clock_roll.R create mode 100644 tests/testthat/test-utils-clock_roll.R diff --git a/NAMESPACE b/NAMESPACE index 3038606..049dc27 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,9 @@ # Generated by roxygen2: do not edit by hand +S3method(clock_roll,Duration) +S3method(clock_roll,Period) +S3method(clock_roll,difftime) +S3method(clock_roll,hms) S3method(convert,Date) S3method(convert,Duration) S3method(convert,Interval) diff --git a/R/utils-clock_roll.R b/R/utils-clock_roll.R new file mode 100644 index 0000000..5241c19 --- /dev/null +++ b/R/utils-clock_roll.R @@ -0,0 +1,59 @@ +clock_roll <- function(x) { + UseMethod("clock_roll") +} + +#' @export +clock_roll.Duration <- function(x) { + if (all(as.numeric(x) > 0 & as.numeric(x) < 86400, na.rm = TRUE)) { + x + } else { + x %>% lubridate::as_datetime() %>% + flat_posixt() %>% + hms::as_hms() %>% + lubridate::as.duration() + } +} + +#' @export +clock_roll.Period <- function(x) { + if (all(as.numeric(x) > 0 & as.numeric(x) < 86400, na.rm = TRUE)) { + x + } else { + x %>% lubridate::as_datetime() %>% + flat_posixt() %>% + hms::as_hms() %>% + lubridate::as.period() + } +} + +#' @export +clock_roll.difftime <- function(x) { + out <- x + units(out) <- "secs" + + if (all(as.numeric(out) > 0 & as.numeric(out) < 86400, na.rm = TRUE)) { + units(out) <- units(x) + out + } else { + out <- out %>% hms::as_hms() %>% + lubridate::as_datetime() %>% + flat_posixt() %>% + hms::as_hms() %>% + as.numeric() %>% + lubridate::as.difftime(units = "secs") + + units(out) <- units(x) + out + } +} + +#' @export +clock_roll.hms <- function(x) { + if (all(as.numeric(x) > 0 & as.numeric(x) < 86400, na.rm = TRUE)) { + x + } else { + x %>% lubridate::as_datetime() %>% + flat_posixt() %>% + hms::as_hms() + } +} diff --git a/R/utils.R b/R/utils.R index 29632f0..4c35d98 100644 --- a/R/utils.R +++ b/R/utils.R @@ -6,50 +6,22 @@ flat_posixt <- function(x, force_utc = TRUE, base = "1970-01-01") { lubridate::date(x) <- base if (isTRUE(force_utc)) { - x <- lubridate::force_tz(x, "UTC") + lubridate::force_tz(x, "UTC") + } else { + x } - - x } midday_change <- function(x) { checkmate::assert_multi_class(x, c("hms", "POSIXct", "POSIXlt")) - x <- flat_posixt(convert(x, "POSIXct")) + if (hms::is_hms(x)) x <- as.POSIXct(x) + x <- flat_posixt(x) - x <- dplyr::case_when( + dplyr::case_when( lubridate::hour(x) < 12 ~ change_day(x, 2), TRUE ~ x ) - - x -} - -clock_roll <- function(x) { - classes <- c("Duration", "Period", "difftime", "hms") - checkmate::assert_multi_class(x, classes) - - class <- class(x)[1] - out <- x - - if (class == "difftime") { - out <- hms::as_hms(x) - units <- units(x) - } - - if (all(as.numeric(out) > 0 & as.numeric(out) < 86400, na.rm = TRUE)) { - x - } else { - out <- flat_posixt(lubridate::as_datetime(out)) - out <- convert(out, class, quiet = TRUE) - - if (class == "difftime") { - units(out) <- units - out - } else { - out - } - } } interval_mean <- function(start, end, class = "hms", ambiguity = 24, @@ -80,10 +52,10 @@ interval_mean <- function(start, end, class = "hms", ambiguity = 24, change_date <- function(x, date) { classes <- c("Date", "POSIXct", "POSIXlt") - checkmate::assert_multi_class(x, classes, null.ok = FALSE) + checkmate::assert_multi_class(x, classes) classes <- c("character", "Date") - checkmate::assert_multi_class(date, classes, null.ok = FALSE) + checkmate::assert_multi_class(date, classes) assert_length_one(date) lubridate::date(x) <- date diff --git a/tests/testthat/test-utils-clock_roll.R b/tests/testthat/test-utils-clock_roll.R new file mode 100644 index 0000000..782717c --- /dev/null +++ b/tests/testthat/test-utils-clock_roll.R @@ -0,0 +1,45 @@ +test_that("clock_roll() | general test", { + # Nonexistent method error + expect_error(clock_roll(list())) +}) + +test_that("clock_roll.Duration() | general test", { + expect_equal(clock_roll(lubridate::dhours(6)), lubridate::dhours(6)) + expect_equal(clock_roll(lubridate::dhours(24)), lubridate::dhours(0)) + expect_equal(clock_roll(lubridate::dhours(36)), lubridate::dhours(12)) + + expect_equal(clock_roll(c(lubridate::dhours(1), lubridate::dhours(48))), + c(lubridate::dhours(1), lubridate::dhours(0))) +}) + +test_that("clock_roll.Period() | general test", { + expect_equal(clock_roll(lubridate::hours(6)), lubridate::hours(6)) + expect_equal(clock_roll(lubridate::hours(24)), lubridate::hours(0)) + expect_equal(clock_roll(lubridate::hours(36)), lubridate::hours(12)) + + expect_equal(clock_roll(c(lubridate::hours(1), lubridate::hours(48))), + c(lubridate::hours(1), lubridate::hours(0))) +}) + +test_that("clock_roll.difftime() | general test", { + expect_equal(clock_roll(as.difftime(6, units = "mins")), + as.difftime(6, units = "mins")) + expect_equal(clock_roll(as.difftime(24, units = "hours")), + as.difftime(0, units = "hours")) + expect_equal(clock_roll(as.difftime(36, units = "hours")), + as.difftime(12, units = "hours")) + + expect_equal(clock_roll(c(as.difftime(1, units = "hours"), + as.difftime(48, units = "hours"))), + c(as.difftime(1, units = "hours"), + as.difftime(0, units = "hours"))) +}) + +test_that("clock_roll.hms() | general test", { + expect_equal(clock_roll(hms::parse_hm("06:00")), hms::parse_hm("06:00")) + expect_equal(clock_roll(hms::parse_hm("24:00")), hms::parse_hm("00:00")) + expect_equal(clock_roll(hms::hms(129600)), hms::parse_hm("12:00")) + + expect_equal(clock_roll(c(hms::parse_hm("01:00"), hms::hms(172800))), + c(hms::parse_hm("01:00"), hms::parse_hm("00:00"))) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index e265519..dd35d33 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -24,23 +24,17 @@ test_that("flat_posixct() | general test", { }) test_that("midday_change() | general test", { - x <- lubridate::ymd_hms("2000-05-04 18:00:00") - object <- midday_change(x) - expect_equal(object, lubridate::ymd_hms("1970-01-01 18:00:00")) - - x <- lubridate::ymd_hms("2000-05-04 06:00:00") - object <- midday_change(x) - expect_equal(object, lubridate::ymd_hms("1970-01-02 06:00:00")) - - x <- c(lubridate::ymd_hms("2020-01-01 18:00:00"), - lubridate::ymd_hms("2020-01-01 06:00:00")) - object <- midday_change(x) - expected <- c(lubridate::ymd_hms("1970-01-01 18:00:00"), - lubridate::ymd_hms("1970-01-02 06:00:00")) - expect_equal(object, expected) - - # Error test - expect_error(midday_change(1)) + expect_equal(midday_change(hms::parse_hm("18:00")), + lubridate::ymd_hms("1970-01-01 18:00:00")) + expect_equal(midday_change(lubridate::ymd_hms("2000-05-04 06:00:00")), + lubridate::ymd_hms("1970-01-02 06:00:00")) + expect_equal(midday_change(c(lubridate::ymd_hms("2020-01-01 18:00:00"), + lubridate::ymd_hms("2020-01-01 06:00:00"))), + c(lubridate::ymd_hms("1970-01-01 18:00:00"), + lubridate::ymd_hms("1970-01-02 06:00:00"))) + + # Assert error test + expect_error(midday_change(1), "but has class 'numeric'") }) test_that("change_date() | general test", { @@ -299,20 +293,6 @@ test_that("get_names() | general test", { expect_equal(object, noquote(c("x", "y", "z"))) }) -test_that("clock_roll() | general test", { - expect_equal(clock_roll(lubridate::dhours(6)), lubridate::dhours(6)) - expect_equal(clock_roll(lubridate::dhours(24)), lubridate::dhours(0)) - expect_equal(clock_roll(lubridate::dhours(36)), lubridate::dhours(12)) - - x <- as.difftime(32, units = "hours") - expect_equal(clock_roll(x), as.difftime(8, units = "hours")) - - x <- c(hms::parse_hm("02:00"), hms::hms(86401)) # 24:00:01 - object <- clock_roll(x) - expected <- c(hms::parse_hm("02:00"), hms::parse_hms("00:00:01")) - expect_equal(object, expected) -}) - test_that("get_class() | general test", { test <- function(x) class(x)[1]