Support infinite values

R/plot.R

@@ -39,7 +39,7 @@ plot.TimeIntervals <- function(x, calendar = getOption("aion.calendar"),
   graphics::plot.new()
 
   ## Set plotting coordinates
-  xlim <- xlim(x, calendar = calendar)
+  xlim <- xlim(x, calendar = calendar, finite = TRUE)
   ylim <- c(1, n)
   graphics::plot.window(xlim = xlim, ylim = ylim)
 
@@ -48,7 +48,15 @@ plot.TimeIntervals <- function(x, calendar = getOption("aion.calendar"),
 
   ## Plot
   for (i in seq_len(n)) {
-    graphics::segments(x0 = int[[i]]$start, x1 = int[[i]]$end, y0 = i, y1 = i,
+    x0 <- int[[i]]$start
+    x1 <- int[[i]]$end
+
+    ## Fix infinite boundaries
+    x0[is.infinite(x0)] <- graphics::par("usr")[[1L]]
+    x1[is.infinite(x1)] <- graphics::par("usr")[[2L]]
+
+    ## Draw segments
+    graphics::segments(x0 = x0, x1 = x1, y0 = i, y1 = i,
                        col = col[[i]], lty = lty[[i]], lwd = lwd[[i]], lend = 1)
   }
 
@@ -349,13 +357,14 @@ setMethod("plot", c(x = "TimeSeries", y = "missing"), plot.TimeSeries)
 #' This ensures that the x axis is always in chronological order.
 #' @param x A [`TimeSeries-class`] object.
 #' @param calendar A [`TimeScale-class`] object.
+#' @param finite A [`logical`] scalar: should non-finite elements be omitted?
 #' @return A length-two [`numeric`] vector.
 #' @keywords internal
 #' @noRd
-xlim <- function(x, calendar) {
+xlim <- function(x, calendar, finite = FALSE) {
   if (methods::is(x, "TimeSeries")) x <- time(x, calendar = NULL)
   if (methods::is(x, "TimeIntervals")) x <- c(start(x, calendar = NULL), end(x, calendar = NULL))
-  x <- range(x)
+  x <- range(x, finite = finite)
   if (is.null(calendar)) return(x)
   as_year(x, calendar = calendar)
 }

R/rd.R

@@ -15,7 +15,7 @@ setMethod(
 
     rd <- fixed(year, 01, 01, calendar = calendar)
 
-    is_leap <- is_gregorian_leap_year(year)
+    is_leap <- which(is_gregorian_leap_year(year))
     rd[is_leap] <- ceiling(rd[is_leap]) # WHY ???
     rd
   }
@@ -52,6 +52,9 @@ setMethod(
       correction +                       # Correct for 28- or 29-day Feb
       day                                # Days so far this month.
 
+    ## Fix infinite values
+    rd[is.infinite(year)] <- year[is.infinite(year)]
+
     .RataDie(rd)
   }
 )
@@ -66,7 +69,7 @@ setMethod(
   definition = function(year, month, day, calendar) {
     ## Correct for 28- or 29-day Feb
     correction <- rep(-2, length(year))
-    correction[is_julian_leap_year(year)] <- -1
+    correction[which(is_julian_leap_year(year))] <- -1
     correction[month <= 2] <- 0
 
     ## There is no year 0 on the Julian calendar
@@ -79,6 +82,9 @@ setMethod(
       correction +                       # Correct for 28- or 29-day Feb
       day                                # Days so far this month.
 
+    ## Fix infinite values
+    rd[is.infinite(year)] <- year[is.infinite(year)]
+
     .RataDie(rd)
   }
 )

R/validate.R

@@ -47,7 +47,8 @@ setValidity(
     ## Validate
     cnd <- list(
       arkhe::validate(arkhe::assert_type(object, "numeric")),
-      arkhe::validate(arkhe::assert_length(time, m))
+      arkhe::validate(arkhe::assert_length(time, m)),
+      arkhe::validate(arkhe::assert_infinite(time))
     )
 
     ## Return conditions, if any

R/year.R

@@ -16,6 +16,9 @@ setMethod(
     ## There is no year 0 on the Julian calendar
     year[year <= 0] <- year[year <= 0] - 1
 
+    ## Fix infinite values
+    year[is.infinite(object)] <- object[is.infinite(object)]
+
     unclass(year)
   }
 )
@@ -80,6 +83,9 @@ setMethod(
       year <- year + sofar / total
     }
 
+    ## Fix infinite values
+    year[is.infinite(object)] <- object[is.infinite(object)]
+
     year
   }
 )
@@ -108,3 +114,27 @@ setMethod(
     )
   }
 )
+
+# Decimal years ================================================================
+#' @export
+#' @rdname as_decimal
+#' @aliases as_decimal,numeric,numeric,numeric,TimeScale-method
+setMethod(
+  f = "as_decimal",
+  signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "TimeScale"),
+  definition = function(year, month, day, calendar) {
+    ## Shift origin
+    year <- (year - calendar_epoch(calendar)) * calendar_direction(calendar)
+
+    ## Year length in days
+    start <- fixed(year, 01, 01, calendar = calendar)
+    end <- fixed(year, 12, 31, calendar = calendar)
+    total <- end - start + 1
+
+    ## Elapsed time
+    date <- fixed(year, month, day, calendar = calendar)
+    sofar <- date - start
+
+    unclass(year + sofar / total)
+  }
+)

inst/tinytest/test_intervals.R

@@ -25,6 +25,14 @@ expect_identical(span(x, calendar = CE()), span(x, calendar = BP()))
 # Overlap ======================================================================
 expect_identical(overlap(x, calendar = CE()), overlap(x, calendar = BP()))
 
+# Inf boundaries ===============================================================
+y <- intervals(start = c(50, -Inf, -Inf), end = c(Inf, 50, Inf), calendar = CE())
+expect_identical(span(y, calendar = CE()), c(Inf, Inf, Inf))
+expect_equivalent(
+  overlap(y, calendar = CE()),
+  matrix(c(Inf, 1, Inf, 1, Inf, Inf, Inf, Inf, Inf), ncol = 3)
+)
+
 # Plot =========================================================================
 if (at_home()) {
   using("tinysnapshot")
@@ -39,4 +47,7 @@ if (at_home()) {
 
   plot_interval_CE <- function() plot(x, calendar = CE())
   expect_snapshot_plot(plot_interval_CE, "plot_interval_CE")
+
+  plot_interval_Inf <- function() plot(y, calendar = CE())
+  expect_snapshot_plot(plot_interval_Inf, "plot_interval_Inf")
 }

inst/tinytest/test_series.R

@@ -5,6 +5,11 @@ X <- series(x, time = seq(100, 109, 0.1), calendar = calendar("BCE"), scale = 10
 Y <- series(x, fixed(1000:1090, calendar = calendar("BCE")))
 expect_identical(X, Y)
 
+expect_error(
+  series(rnorm(3), fixed(c(50, Inf, 250), calendar = calendar("CE"))),
+  "must not contain infinite values"
+)
+
 # Create from matrix ===========================================================
 x <- matrix(rnorm(300), 100, 3)