[Fix #284] Compute periods in as.period.interval without recurring to…

… modulo arithmetic

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

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
 #'

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"), 

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)
-})
+})
+