Fix time span calculation

R/AllGenerics.R

@@ -335,8 +335,6 @@ setGeneric(
 #'  (see [calendar()]).
 #' @param decimal A [`logical`] scalar: should decimal years be returned?
 #'  If `FALSE`, the decimal part is dropped.
-#' @param shift A [`logical`] scalar: should years be shifted according to the
-#'  [calendar epoch][calendar_epoch()]?
 #' @param ... Currently not used.
 #' @return
 #'  A [`numeric`] vector of (decimal) years.
@@ -613,7 +611,7 @@ NULL
 #' Durations
 #'
 #' Get the duration of time series or intervals.
-#' @param x A [`TimeSeries-class`] object.
+#' @param x A [`TimeSeries-class`] or a [`TimeIntervals-class`] object.
 #' @param calendar A [`TimeScale-class`] object specifying the target calendar
 #'  (see [calendar()]). If `NULL` (the default), *rata die* are returned.
 #' @param ... Currently not used.

R/calendar-gregorian.R

@@ -40,6 +40,13 @@ setMethod(
   f = "fixed",
   signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "GregorianCalendar"),
   definition = function(year, month, day, calendar) {
+    ## Recycle
+    n <- length(year)
+    if (n > 1) {
+      if (length(month) == 1) month <- rep(month, n)
+      if (length(day) == 1) day <- rep(day, n)
+    }
+
     ## Switch origin
     year <- (year - calendar_epoch(calendar)) * calendar_direction(calendar)
 
@@ -68,7 +75,7 @@ setMethod(
 setMethod(
   f = "as_year",
   signature = c(object = "numeric", calendar = "GregorianCalendar"),
-  definition = function(object, calendar, decimal = TRUE, shift = TRUE, ...) {
+  definition = function(object, calendar, decimal = TRUE, ...) {
     d0 <- object - calendar_fixed(calendar)
     n400 <- d0 %/% 146097
     d1 <- d0 %% 146097
@@ -81,21 +88,19 @@ setMethod(
     year <- 400 * n400 + 100 * n100 + 4 * n4 + n1
     year <- ifelse(n100 == 4 | n1 == 4, year, year + 1)
 
-    if (isTRUE(shift)) {
-      ## Shift origin
-      year <- (year - calendar_epoch(calendar)) * calendar_direction(calendar)
+    ## Shift origin
+    year <- (year - calendar_epoch(calendar)) * calendar_direction(calendar)
 
-      if (isTRUE(decimal)) {
-        ## Year length in days
-        start <- fixed(year, 01, 01, calendar = calendar)
-        end <- fixed(year, 12, 31, calendar = calendar)
-        total <- end - start + 1
+    if (isTRUE(decimal)) {
+      ## Year length in days
+      start <- fixed(year, 01, 01, calendar = calendar)
+      end <- fixed(year, 12, 31, calendar = calendar)
+      total <- end - start + 1
 
-        ## Elapsed time
-        sofar <- object - start
+      ## Elapsed time
+      sofar <- object - start
 
-        year <- year + sofar / total
-      }
+      year <- year + sofar / total
     }
 
     year

R/intervals.R

@@ -32,15 +32,17 @@ setMethod(
       msg <- "%s is already expressed in rata die: %s is ignored."
       warning(sprintf(msg, sQuote("start"), sQuote("calendar")), call. = FALSE)
     } else {
-      start <- fixed(start, calendar = calendar, scale = scale)
+      start <- start * scale # Rescale to years
+      start <- fixed(start, 01, 01, calendar = calendar)
     }
 
     ## End
     if (methods::is(end, "RataDie")) {
       msg <- "%s is already expressed in rata die: %s is ignored."
       warning(sprintf(msg, sQuote("end"), sQuote("calendar")), call. = FALSE)
     } else {
-      end <- fixed(end, calendar = calendar, scale = scale)
+      end <- end * scale # Rescale to years
+      end <- fixed(end, 12, 31, calendar = calendar)
     }
 
     names <- names %||% names(start) %||% names(end)

R/overlap.R

@@ -24,7 +24,8 @@ setMethod(
 
     ## Convert to calendar years
     if (!is.null(calendar)) {
-      index <- as_year(index, calendar = calendar, shift = FALSE)
+      index <- as_year(index, calendar = calendar, decimal = FALSE)
+      index <- abs(index - calendar_epoch(calendar))
     }
 
     ## Matrix of results

R/span.R

@@ -7,11 +7,12 @@ NULL
 #' @aliases span,TimeSeries-method
 setMethod(
   f = "span",
-  signature = "TimeSeries",
+  signature = c(x = "TimeSeries"),
   definition = function(x, calendar = NULL) {
     z <- max(x@.Time) - min(x@.Time)
     if (is.null(calendar)) return(unclass(z))
-    as_year(z, calendar = calendar, shift = FALSE)
+    y <- as_year(z, calendar = calendar, decimal = FALSE)
+    abs(y - calendar_epoch(calendar))
   }
 )
 
@@ -20,10 +21,11 @@ setMethod(
 #' @aliases span,TimeIntervals-method
 setMethod(
   f = "span",
-  signature = "TimeIntervals",
+  signature = c(x = "TimeIntervals"),
   definition = function(x, calendar = NULL) {
     z <- x@.End - x@.Start
     if (is.null(calendar)) return(unclass(z))
-    as_year(z, calendar = calendar, shift = FALSE)
+    y <- as_year(z, calendar = calendar, decimal = FALSE)
+    abs(y - calendar_epoch(calendar)) - 1 #WHY?
   }
 )

R/time.R

@@ -11,7 +11,7 @@ setMethod(
   definition = function(x, calendar = NULL) {
     z <- min(x@.Time)
     if (is.null(calendar)) return(z)
-    as_year(z, calendar = calendar, decimal = TRUE)
+    as_year(z, calendar = calendar, decimal = FALSE)
   }
 )
 
@@ -24,7 +24,7 @@ setMethod(
   definition = function(x, calendar = NULL) {
     z <- x@.Start
     if (is.null(calendar)) return(z)
-    as_year(z, calendar = calendar, decimal = TRUE)
+    as_year(z, calendar = calendar, decimal = FALSE)
   }
 )
 
@@ -37,7 +37,7 @@ setMethod(
   definition = function(x, calendar = NULL) {
     z <- max(x@.Time)
     if (is.null(calendar)) return(z)
-    as_year(z, calendar = calendar, decimal = TRUE)
+    as_year(z, calendar = calendar, decimal = FALSE)
   }
 )
 
@@ -50,7 +50,7 @@ setMethod(
   definition = function(x, calendar = NULL) {
     z <- x@.End
     if (is.null(calendar)) return(z)
-    as_year(z, calendar = calendar, decimal = TRUE)
+    as_year(z, calendar = calendar, decimal = FALSE)
   }
 )
 
@@ -63,7 +63,7 @@ setMethod(
   definition = function(x, calendar = NULL) {
     z <- x@.Time
     if (is.null(calendar)) return(z)
-    as_year(z, calendar = calendar, decimal = TRUE)
+    as_year(z, calendar = calendar, decimal = FALSE)
   }
 )
 

inst/tinytest/test_intervals.R

@@ -19,6 +19,7 @@ expect_identical(start(x, calendar = CE()), lower)
 expect_identical(end(x, calendar = CE()), upper)
 
 # Duration =====================================================================
+expect_identical(span(x, calendar = CE()), upper - lower)
 expect_identical(span(x, calendar = CE()), span(x, calendar = BP()))
 
 # Overlap ======================================================================