[Fix #285] Implement asymmetric treatment of negative periods

See #285 for the motivation and examples.
tidyverse · Sep 30, 2015 · 9597591 · 9597591
1 parent 623f2f0
commit 9597591
Show file tree

Hide file tree

Showing 4 changed files with 127 additions and 44 deletions.
diff --git a/R/accessors-month.r b/R/accessors-month.r
@@ -91,6 +91,13 @@ days_in_month <- function(x) {
   n_days
 }
 
+## fixme: integrate with above, this oen is needed internally
+.days_in_month <- function(m, y){
+  n_days <- N_DAYS_IN_MONTHS[m]
+  n_days[m == 2L & leap_year(y)] <- 29L
+  n_days
+}
+
 ## tothink: export?
 days_in_months_so_far <- function(month, leap){
   ## if month is negative, compute from the end of the year

diff --git a/R/coercion.r b/R/coercion.r
@@ -379,48 +379,46 @@ setMethod("as.period", signature(x = "difftime"), function(x, unit = NULL, ...){
 })
 
 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])
 
-  ## fixme: the default must be "days". "year" leads to loose arithmetics and
-  ## bugs like #336
   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
-           },
-           ## fixme: add note to the docs that unit <= days results in much faster conversion
-           ## fixme: add week
-           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
+  switch(unit,
+         year = .int_to_period(x),
+         month = {
+           pers <- .int_to_period(x)
+           month(pers) <- month(pers) + year(pers)*12L
+           year(pers) <- 0L
+           pers
+         },
+         ## fixme: add note to the docs that unit <= days results in much faster conversion
+         ## fixme: add week
+         day = , hour = , minute = , second = {
+           secs <- x@.Data
+           negs <- secs < 0 & !is.na(secs)
+           units <- .units_within_seconds(abs(secs), unit)
+           pers <- do.call("new", c("Period", units))
+           pers[negs] <- -pers[negs]
+           pers
+         },
+         stop("Unsuported unit ", unit))
 })
-  
+
 .int_to_period <- function(x){
   ## this function is called only for conversion with units > day
   start <- as.POSIXlt(x@start)
   end <- as.POSIXlt(start + x@.Data)
 
+  negs <- x@.Data < 0 & !is.na(x@.Data)
+
   per <- list()
 
   for(nm in c("sec", "min", "hour", "mday", "mon", "year")){
-    per[[nm]] <- end[[nm]] - start[[nm]]
+    per[[nm]] <- ifelse(negs, start[[nm]] - end[[nm]], end[[nm]] - start[[nm]])
   }
 
+  pero <- per
   names(per) <- c("second", "minute", "hour", "day", "month", "year")
 
   ## Remove negative ...
@@ -429,41 +427,69 @@ setMethod("as.period", signature(x = "Interval"), function(x, unit = NULL, ...)
   nsecs <- per$second < 0L & !is.na(per$second)
   per$second[nsecs] <- 60L + per$second[nsecs]
   per$minute[nsecs] <- per$minute[nsecs] - 1L
+  per$second[negs] <- -per$second[negs]
 
   ## minutes
   nmins <- per$minute < 0L & !is.na(per$minute)
   per$minute[nmins] <- 60L + per$minute[nmins]
   per$hour[nmins] <- per$hour[nmins] - 1L
-
+  per$minute[negs] <- -per$minute[negs]
+
   ## hours
   nhous <- per$hour < 0L & !is.na(per$hour)
   per$hour[nhous] <- 24L + per$hour[nhous]
+  per$hour[negs] <- -per$hour[negs]
 
   ## days
-  ndays <- per$day < 0 & !is.na(per$day)
+
+  ### postivie periods
+  ndays <- !negs & per$day < 0 & !is.na(per$day)
   if (any(ndays)) {
 
     ## compute nr days in previous month
     add_months <- rep.int(-1L, sum(ndays))
+
     ## no need to substract a month for negative months. For ex:
     ## as.period(interval(ymd("1985-12-31"), ymd("1986-02-01")))
     add_months[per$month[ndays] < 0] <- 0L
-    prev_month_days <- days_in_month(.quick_month_add(end[ndays], add_months))
+    pmonth <- end$mon[ndays]
+    pmonth[pmonth == 0L] <- 1L #dec == jan == 31 days
+    prev_month_days <- .days_in_month(pmonth, end$year[ndays])
 
-    ## Compute nr of days:
+    ## difference in days:
     ## /need pmax to capture as.period(interval(ymd("1985-01-31"), ymd("1986-03-28")))/
     per$day[ndays] <- pmax(prev_month_days - start$mday[ndays], 0) + end$mday[ndays]
     per$month[ndays] <- per$month[ndays] + add_months
   }
 
+  ## negative periods
+  ndays <- negs & per$day < 0 & !is.na(per$day)
+  if (any(ndays)) {
+
+    add_months <- rep.int(1L, sum(ndays))
+    ## no need to substract for negative months as in
+    ## as.period(interval(ymd("1986-02-01"), ymd("1985-12-31")))
+    add_months[per$month[ndays] < 0] <- 0L
+    this_month_days <- .days_in_month(end$mon[ndays] + 1L, end$year[ndays])
+
+    ## Compute nr of days:
+    ## /need pmax to capture as.period(interval(ymd("1985-01-31"), ymd("1986-03-28")))/
+    per$day[ndays] <- pmax(this_month_days - end$mday[ndays], 0) + start$mday[ndays]
+    per$month[ndays] <- per$month[ndays] - add_months
+  }
+
   ## substract only after the day computation to capture intervals like:
   ## as.period(interval(ymd_hms("1985-12-31 5:0:0"), ymd_hms("1986-02-01 3:0:0")))
   per$day[nhous] <- per$day[nhous] - 1L
+  per$day[negs] <- -per$day[negs]
 
   ## months
   nmons <- per$month < 0L & !is.na(per$month)
   per$month[nmons] <- 12L + per$month[nmons]
   per$year[nmons] <- per$year[nmons] - 1L
+  per$month[negs] <- -per$month[negs]
+
+  per$year[negs] <- -per$year[negs]
 
   new("Period", per$second, year = per$year, month = per$month, 
     day = per$day, hour = per$hour, minute = per$minute)

diff --git a/tests/testthat/test-periods.R b/tests/testthat/test-periods.R
@@ -137,14 +137,12 @@ test_that("as.period with different units handles negative interval objects", {
     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))
+                equals(period(-c(18, 9, 5, 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"))))
-    ## fixme: #285
-    ## expect_that(as.period(int, "months") + start, equals(end))
+                equals(period(-c(225, 5, 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))
@@ -157,6 +155,7 @@ test_that("as.period with different units handles negative interval objects", {
 })
 
 test_that("as.period handles tricky intervals", {
+
   expect_equal(
     as.period(interval(ymd("1986-01-31"), ymd("1986-02-01")))
   , new_period(days = 1))
@@ -202,7 +201,58 @@ test_that("as.period handles tricky intervals", {
   , new_period(months = 1, days = 1, hours = 22))
 })
 
+
+
+test_that("as.period handles tricky negative intervals", {
+
+  expect_equal(
+    as.period(interval(ymd("1986-02-01"), ymd("1986-01-31")))
+  , new_period(days = -1))
+
+  expect_equal(
+    as.period(interval(ymd("1986-02-01"), ymd("1984-01-30")))
+  , new_period(years = -2, days = -2))
+
+  expect_equal(
+    as.period(interval(ymd("1986-03-01"), ymd("1984-01-30")))
+  , new_period(years = -2, months = -1, days = -2))
+
+  expect_equal(
+    as.period(interval(ymd("1986-03-30"), ymd("1985-01-30")))
+  , new_period(years = -1, months = -2))
+
+  expect_equal(
+    as.period(interval(ymd("1986-03-28"), ymd("1985-01-28")))
+  , new_period(years = -1, months = -2))
+
+  expect_equal(
+    as.period(interval(ymd("1986-03-28"), ymd("1985-01-31")))
+  , new_period(years = -1, months = -1, days = -28))
+
+  expect_equal(
+    as.period(interval(ymd("1986-02-01"), ymd("1985-12-31")))
+  , new_period(months = -2, days = -1))
+
+  expect_equal(
+    as.period(interval(ymd("1984-03-01"), ymd("1984-01-31")))
+  , new_period(months = -1, days = -1))
+
+  expect_equal(
+    as.period(interval(ymd("1984-03-01"), ymd("1984-01-30")))
+  , new_period(months = -1, days = -2))
+
+  expect_equal(
+    as.period(interval(ymd("1984-03-01"), ymd("1984-01-29")))
+  , new_period(months = -1, days = -3))
+
+  expect_equal(
+    as.period(interval(ymd_hms("1984-03-01 3:0:0"), ymd_hms("1984-01-28 5:0:0")))
+  , new_period(months = -1, days = -3, hours = -22))
+
+})
+
 test_that("as.period handles NA in interval objects", {
+
   one_missing_date <- as.POSIXct(NA_real_, origin = origin)
   one_missing_interval <- new_interval(one_missing_date, 
     one_missing_date)

diff --git a/tests/testthat/test-timespans.R b/tests/testthat/test-timespans.R
@@ -58,17 +58,17 @@ test_that("time_length works with negative interals", {
   expect_that(-time_length(interval(ymd('1992-02-28'), ymd('2000-03-01')), "days"),
               equals(time_length(int_flip(interval(ymd('1992-02-28'), ymd('2000-03-01'))), "days")))
 
-  ## If both ends include leap years Febs, the lenths are identical
-  expect_true(-time_length(interval(ymd('1992-02-28'), ymd('2000-03-01')), "years") == 
-                time_length(int_flip(interval(ymd('1992-02-28'), ymd('2000-03-01'))), "years"))
+  ## If both ends include leap years Febs, the lenths are not identical
+  int <- interval(ymd('1992-02-28'), ymd('2000-03-01'))
+  expect_equal(-time_length(int, "years"), time_length(int_flip(int), "years"))
 
-  ## or if both ends doesn't include leap years Febs, the lenths are identical
-  expect_true(-time_length(interval(ymd('1994-02-28'), ymd('2002-03-01')), "years") == 
-                time_length(int_flip(interval(ymd('1994-02-28'), ymd('2002-03-01'))), "years"))
+  ## or if both ends don't include leap years Febs, the lenths are identical
+  int <- interval(ymd('1994-02-28'), ymd('2002-03-01'))
+  expect_equal(-time_length(int, "years"), time_length(int_flip(int), "years"))
 
   ## ... otherwise not
-  expect_false(-time_length(interval(ymd('1992-02-28'), ymd('2002-01-01')), "years") == 
-                 time_length(int_flip(interval(ymd('1992-02-28'), ymd('2002-01-01'))), "years"))
+  int <- interval(ymd('1992-02-28'), ymd('2002-01-01'))
+  expect_more_than(-time_length(int, "years"),  time_length(int_flip(int), "years"))
 })
 
 test_that("time_length handles vectors",{