diff --git a/R/coercion.r b/R/coercion.r index e9909930..d5561e29 100644 --- a/R/coercion.r +++ b/R/coercion.r @@ -395,17 +395,25 @@ setMethod("as.period", signature(x = "Interval"), function(x, unit = NULL, ...) negs <- int_length(x) < 0 & !is.na(int_length(x)) x[negs] <- int_flip(x[negs]) - if (missing(unit)) { - pers <- .int_to_period(x) - pers[negs] <- -1 * pers[negs] - return(pers) - } else { - unit <- standardise_period_names(unit) - per <- get(paste(unit, "s", sep = "")) - num <- x %/% per(1) - left_over <- x %% per(1) - pers <- per(num) + .int_to_period(left_over) - } + unit <- + if (missing(unit)) "year" + else standardise_period_names(unit) + + pers <- + switch(unit, + year = .int_to_period(x), + month = { + pers <- .int_to_period(x) + month(pers) <- month(pers) + year(pers)*12L + year(pers) <- 0L + pers + }, + day = , hour = , minute = , second = { + secs <- abs(x@.Data) + units <- .units_within_seconds(secs, unit) + do.call("new", c("Period", units)) + }, + stop("Unsuported unit ", unit)) pers[negs] <- -1 * pers[negs] pers diff --git a/R/intervals.r b/R/intervals.r index d4435e17..dd37f4c5 100644 --- a/R/intervals.r +++ b/R/intervals.r @@ -23,6 +23,20 @@ check_interval <- function(object){ errors } +.units_within_seconds <- function(secs, unit = "second"){ + ## return a list suitable to pass to new("Period", ...) + switch(unit, + second = list(secs), + minute = list(secs %% 60, minute = secs %/% 60), + hour = + c(.units_within_seconds(secs %% 3600, "minute"), + list(hour = secs %/% 3600)), + day = + c(.units_within_seconds(secs %% 86400, "hour"), + day = secs %/% 86400), + stop("Unsuported unit ", unit)) +} + #' Interval class #' diff --git a/R/ops-division.r b/R/ops-division.r index 5949639f..92865ee3 100644 --- a/R/ops-division.r +++ b/R/ops-division.r @@ -131,7 +131,7 @@ setMethod("/", signature(e1 = "Interval", e2 = "Interval"), function(e1, e2) { #' @export setMethod("/", signature(e1 = "Interval", e2 = "Period"), - function(e1, e2) divide_interval_by_period(e1, e2)) + function(e1, e2)divide_interval_by_period(e1, e2)) #' @export setMethod("/", signature(e1 = "Interval", e2 = "difftime"), diff --git a/inst/tests/test-periods.R b/inst/tests/test-periods.R index 6799cf2a..ccfd2c30 100644 --- a/inst/tests/test-periods.R +++ b/inst/tests/test-periods.R @@ -78,13 +78,75 @@ test_that("format.Period works as expected", { }) test_that("as.period handles interval objects", { - time1 <- as.POSIXct("2008-08-03 13:01:59", tz = "UTC") - time2 <- as.POSIXct("2009-08-03 13:01:59", tz = "UTC") - int <- new_interval(time1, time2) + start <- as.POSIXct("2008-08-03 13:01:59", tz = "UTC") + end <- as.POSIXct("2009-08-03 13:01:59", tz = "UTC") + int <- new_interval(start, end) + int_neg <- new_interval(end, start) expect_that(as.period(int), equals(years(1))) + expect_that(as.period(int_neg), equals(years(-1))) +}) + +test_that("as.period handles interval objects with special start dates", { + start <- ymd('1992-02-29') + end <- ymd('2010-12-05') + int <- new_interval(start, end) + + expect_that(as.period(int), equals(period(c(18, 9, 6), c("year", "month", "day")))) + expect_that(as.period(int) + start, equals(end)) +}) + + +test_that("as.period with different units handles interval objects", { + start <- ymd('1992-02-29') + end <- ymd_hms('2010-12-05 01:02:03') + int <- new_interval(start, end) + + expect_that(as.period(int), + equals(period(c(18, 9, 6, 1, 2, 3), c("year", "month", "day", "hour", "minute", "second")))) + expect_that(as.period(int) + start, equals(end)) + + expect_that(as.period(int, "months"), + equals(period(c(225, 6, 1, 2, 3), c("month", "day", "hour", "minute", "second")))) + expect_that(as.period(int, "months") + start, equals(end)) + + expect_that(as.period(int, "hours"), equals(period(c(164497, 2, 3), c("hour", "minute", "second")))) + expect_that(as.period(int, "hours") + start, equals(end)) + + expect_that(as.period(int, "minute"), equals(period(c(9869822, 3), c("minute", "second")))) + expect_that(as.period(int, "minute") + start, equals(end)) + + expect_that(as.period(int, "second"), equals(period(c(592189323), c("second")))) + expect_that(as.period(int, "second") + start, equals(end)) +}) + + +test_that("as.period with different units handles negative interval objects", { + end <- ymd('1992-02-29') + start <- ymd_hms('2010-12-05 01:02:03') + int <- new_interval(start, end) + + expect_that(as.period(int), + equals(period(-c(18, 9, 6, 1, 2, 3), c("year", "month", "day", "hour", "minute", "second")))) + ## fixme: #285 + ## expect_that(as.period(int) + start, equals(end)) + + expect_that(as.period(int, "months"), + equals(period(-c(225, 6, 1, 2, 3), c("month", "day", "hour", "minute", "second")))) + ## fixme: #285 + ## expect_that(as.period(int, "months") + start, equals(end)) + + expect_that(as.period(int, "hours"), equals(period(-c(164497, 2, 3), c("hour", "minute", "second")))) + expect_that(as.period(int, "hours") + start, equals(end)) + + expect_that(as.period(int, "minute"), equals(period(-c(9869822, 3), c("minute", "second")))) + expect_that(as.period(int, "minute") + start, equals(end)) + + expect_that(as.period(int, "second"), equals(period(-c(592189323), c("second")))) + expect_that(as.period(int, "second") + start, equals(end)) }) + test_that("as.period handles NA interval objects", { one_missing_date <- as.POSIXct(NA_real_, origin = origin) one_missing_interval <- new_interval(one_missing_date, @@ -176,4 +238,5 @@ test_that("summary.Period creates useful summary", { names(text) <- c("Min.", "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.", "NA's") expect_equal(summary(c(per, NA)), text) -}) \ No newline at end of file +}) +