Add conversion methods

R/calendar-gregorian.R

@@ -14,6 +14,129 @@ setMethod(
   }
 )
 
+# Fixed from Gregorian =========================================================
+#' @export
+#' @rdname fixed
+#' @aliases fixed,numeric,missing,missing,GregorianCalendar-method
+setMethod(
+  f = "fixed",
+  signature = c(year = "numeric", month = "missing", day = "missing", calendar = "GregorianCalendar"),
+  definition = function(year, calendar, scale = 1) {
+    ## Rescale to years (if not already)
+    year <- year * scale
+
+    rd <- fixed(year, 01, 01, calendar = calendar)
+
+    is_leap <- which(is_gregorian_leap_year(year))
+    rd[is_leap] <- ceiling(rd[is_leap]) # WHY ???
+    rd
+  }
+)
+
+#' @export
+#' @rdname fixed
+#' @aliases fixed,numeric,numeric,numeric,GregorianCalendar-method
+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)
+
+    ## Correct for 28- or 29-day Feb
+    correction <- rep(-2, length(year))
+    correction[is_gregorian_leap_year(year)] <- -1
+    correction[month <= 2] <- 0
+
+    rd <- calendar_fixed(calendar) - 1 + # Days before start of calendar
+      365 * (year - 1) +                 # Ordinary days since epoch
+      (year - 1) %/% 4 -                 # Julian leap days since epoch minus...
+      (year - 1) %/% 100 +               # ...century years since epoch plus...
+      (year - 1) %/% 400 +               # ...years since epoch divisible by 400
+      (367 * month - 362) %/% 12 +       # Days in prior months this year assuming 30-day Feb
+      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)
+  }
+)
+# Gregorian from fixed =========================================================
+#' @export
+#' @rdname as_year
+#' @aliases as_year,numeric,GregorianCalendar-method
+setMethod(
+  f = "as_year",
+  signature = c(object = "numeric", calendar = "GregorianCalendar"),
+  definition = function(object, calendar, decimal = TRUE, ...) {
+    d0 <- object - calendar_fixed(calendar)
+    n400 <- d0 %/% 146097
+    d1 <- d0 %% 146097
+    n100 <- d1 %/% 36524
+    d2 <- d1 %% 36524
+    n4 <- d2 %/% 1461
+    d3 <- d2 %% 1461
+    n1 <- d3 %/% 365
+
+    year <- 400 * n400 + 100 * n100 + 4 * n4 + n1
+    year <- ifelse(n100 == 4 | n1 == 4, year, year + 1)
+
+    ## 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
+
+      ## Elapsed time
+      sofar <- object - start
+
+      year <- year + sofar / total
+    }
+
+    ## Fix infinite values
+    year[is.infinite(object)] <- object[is.infinite(object)]
+
+    year
+  }
+)
+
+#' @export
+#' @rdname as_date
+#' @aliases as_date,numeric,GregorianCalendar-method
+setMethod(
+  f = "as_date",
+  signature = c(object = "numeric", calendar = "GregorianCalendar"),
+  definition = function(object, calendar) {
+    year <- as_year(object, calendar = calendar, decimal = FALSE)
+    prior_days <- object - fixed(year, 01, 01, calendar = calendar)
+
+    correction <- rep(2, length(object))
+    correction[object < fixed(year, 03, 01, calendar = calendar)] <- 0
+    correction[is_gregorian_leap_year(year)] <- 1
+
+    month <- (12 * (prior_days + correction) + 373) %/% 367
+    day <- object - fixed(year, month, 01, calendar = calendar) + 1
+
+    data.frame(
+      year = as.numeric(year),
+      month = as.numeric(month),
+      day = as.numeric(day)
+    )
+  }
+)
+
 # Era ==========================================================================
 #' @export
 #' @rdname fixed_gregorian
@@ -86,12 +209,3 @@ fixed_from_b2k <- function(year, month, day) {
 fixed_to_b2k <- function(object) {
   as_year(object, calendar = b2k(), decimal = TRUE)
 }
-
-# Helpers ======================================================================
-is_gregorian_leap_year <- function(year) {
-  year <- floor(year) # Drop decimal part (if any)
-  ((year %% 4) == 0) &
-    (year %% 400 != 100) &
-    (year %% 400 != 200) &
-    (year %% 400 != 300)
-}

R/calendar-julian.R

@@ -2,7 +2,7 @@
 #' @include AllGenerics.R
 NULL
 
-# Juliab calendar ==============================================================
+# Julian calendar ==============================================================
 #' @export
 #' @rdname is
 #' @aliases is_julian,ANY-method
@@ -14,23 +14,127 @@ setMethod(
   }
 )
 
+# Fixed from Julian ============================================================
+#' @export
+#' @rdname fixed
+#' @aliases fixed,numeric,missing,missing,JulianCalendar-method
+setMethod(
+  f = "fixed",
+  signature = c(year = "numeric", month = "missing", day = "missing", calendar = "JulianCalendar"),
+  definition = function(year, calendar, scale = 1) {
+    ## Rescale to years (if not already)
+    year <- year * scale
+
+    rd <- fixed(year, 01, 01, calendar = calendar)
+
+    is_leap <- which(is_julian_leap_year(year))
+    rd[is_leap] <- ceiling(rd[is_leap]) # WHY ???
+    rd
+  }
+)
+
+#' @export
+#' @rdname fixed
+#' @aliases fixed,numeric,numeric,numeric,JulianCalendar-method
+setMethod(
+  f = "fixed",
+  signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "JulianCalendar"),
+  definition = function(year, month, day, calendar) {
+    ## Validation
+    if (any(year == 0)) {
+      stop(tr_("There is no year zero in the Julian calendar."), call. = FALSE)
+    }
+
+    ## Correct for 28- or 29-day Feb
+    correction <- rep(-2, length(year))
+    correction[which(is_julian_leap_year(year))] <- -1
+    correction[month <= 2] <- 0
+
+    ## There is no year 0 on the Julian calendar
+    year[year < 0] <- year[year < 0] + 1
+
+    rd <- calendar_fixed(calendar) - 1 + # Days before start of calendar
+      365 * (year - 1) +                 # Ordinary days since epoch
+      (year - 1) %/% 4 +                 # Leap days since epoch
+      (367 * month - 362) %/% 12 +       # Days in prior months this year assuming 30-day Feb
+      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)
+  }
+)
+
+# Julian from fixed ============================================================
+#' @export
+#' @rdname as_year
+#' @aliases as_year,numeric,JulianCalendar-method
+setMethod(
+  f = "as_year",
+  signature = c(object = "numeric", calendar = "JulianCalendar"),
+  definition = function(object, calendar, decimal = FALSE, ...) {
+    d0 <- object - calendar_fixed(calendar)
+    year <- (4 * d0 + 1464) %/% 1461
+
+    ## There is no year 0 on the Julian calendar
+    year[year <= 0] <- year[year <= 0] - 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
+
+      year <- year + sofar / total
+    }
+
+    ## Fix infinite values
+    year[is.infinite(object)] <- object[is.infinite(object)]
+
+    unclass(year)
+  }
+)
+
+#' @export
+#' @rdname as_date
+#' @aliases as_date,numeric,JulianCalendar-method
+setMethod(
+  f = "as_date",
+  signature = c(object = "numeric", calendar = "JulianCalendar"),
+  definition = function(object, calendar) {
+    year <- as_year(object, calendar = calendar, decimal = FALSE)
+    prior_days <- object - fixed(year, 01, 01, calendar = calendar)
+
+    correction <- rep(2, length(object))
+    correction[object < fixed(year, 03, 01, calendar = calendar)] <- 0
+    correction[is_julian_leap_year(year)] <- 1
+
+    month <- (12 * (prior_days + correction) + 373) %/% 367
+    day <- object - fixed(year, month, 01, calendar = calendar) + 1
+
+    data.frame(
+      year = unclass(year),
+      month = unclass(month),
+      day = unclass(day)
+    )
+  }
+)
+
 # Era ==========================================================================
 #' @export
 #' @rdname fixed_julian
 fixed_from_julian <- function(year, month, day) {
   if (missing(month) || missing(day)) fixed(year, calendar = J())
   else fixed(year, month, day, calendar = J())
 }
+
 #' @export
 #' @rdname fixed_julian
 fixed_to_julian <- function(object) {
   as_year(object, calendar = J())
 }
-
-# Helpers ======================================================================
-is_julian_leap_year <- function(year) {
-  year <- floor(year) # Drop decimal part (if any)
-  leap <- year %% 4 == 3
-  leap[year > 0] <- year[year > 0] %% 4 == 0
-  leap
-}