1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
#' @title Julian CF calendar
#'
#' @description This class represents a Julian calendar of 365 days per year,
#' with every fourth year being a leap year of 366 days. The months and the
#' year align with the standard calendar. This calendar is not compatible with
#' the standard POSIXt calendar.
#'
#' This calendar starts on 1 January of year 1: 0001-01-01 00:00:00. Any dates
#' before this will generate an error.
#'
#' @aliases CFCalendarJulian
#' @docType class
CFCalendarJulian <- R6::R6Class("CFCalendarJulian",
inherit = CFCalendar,
private = list(
# Rata Die, the number of days from the day before 0001-01-01 to
# origin of this calendar. Used to convert offsets from the calendar origin
# to the day before 0001-01-01 for arithmetic calculations.
rd = 0L
),
public = list(
#' @description Create a new CF calendar.
#' @param nm The name of the calendar. This must be "julian". This argument
#' is superfluous but maintained to be consistent with the initialization
#' methods of the parent and sibling classes.
#' @param definition The string that defines the units and the origin, as
#' per the CF Metadata Conventions.
#' @return A new instance of this class.
initialize = function(nm, definition) {
super$initialize(nm, definition)
private$rd <- .julian_date2offset(self$origin, self$leap_year(self$origin$year))
},
#' @description Indicate which of the supplied dates are valid.
#' @param ymd `data.frame` with dates parsed into their parts in columns
#' `year`, `month` and `day`. Any other columns are disregarded.
#' @return Logical vector with the same length as argument `ymd` has rows
#' with `TRUE` for valid days and `FALSE` for invalid days, or `NA` where
#' the row in argument `ymd` has `NA` values.
valid_days = function(ymd) {
ymd$year >= 1L & ymd$month >= 1L & ymd$month <= 12L & ymd$day >= 1L &
ifelse(self$leap_year(ymd$year),
ymd$day <= c(31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[ymd$month],
ymd$day <= c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[ymd$month])
},
#' @description Determine the number of days in the month of the calendar.
#' @param ymd `data.frame`, optional, with dates parsed into their parts.
#' @return A vector indicating the number of days in each month for the
#' dates supplied as argument `ymd`. If no dates are supplied, the number
#' of days per month for the calendar as a vector of length 12, for a
#' regular year without a leap day.
month_days = function(ymd = NULL) {
if (is.null(ymd)) return(c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31))
ifelse(self$leap_year(ymd$year),
c(31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[ymd$month],
c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[ymd$month])
},
#' @description Indicate which years are leap years.
#' @param yr Integer vector of years to test.
#' @return Logical vector with the same length as argument `yr`. `NA` is
#' returned where elements in argument `yr` are `NA`.
leap_year = function(yr) {
yr %% 4L == 0L
},
#' @description Calculate difference in days between a `data.frame` of time
#' parts and the origin.
#'
#' @param x `data.frame`. Dates to calculate the difference for.
#' @return Integer vector of a length equal to the number of rows in
#' argument `x` indicating the number of days between `x` and the origin
#' of the calendar, or `NA` for rows in `x` with `NA` values.
date2offset = function(x) {
.julian_date2offset(x, self$leap_year(x$year)) - private$rd
},
#' @description Calculate date parts from day differences from the origin. This
#' only deals with days as these are impacted by the calendar.
#' Hour-minute-second timestamp parts are handled in [CFCalendar].
#'
#' @param x Integer vector of days to add to the origin.
#' @return A `data.frame` with columns 'year', 'month' and 'day' and as many
#' rows as the length of vector `x`.
offset2date = function(x) {
.julian_offset2date(x + private$rd)
}
)
)
# ==============================================================================
# The below functions use arithmetic offset calculation from date parts and
# vice-versa. These functions are R-ified from pseudo-functions in Reingold &
# Derschowitz, "Calendrical Calculations", 2018.
#' Dates to offset, from function `fixed-from-julian()`
#'
#' @param x `data.frame` with columns "year", "month" and "date"
#' @param leapyear Logical vector of the same length as `x` has rows indicating
#' for each row in `x` if this is a leap year.
#' @return Integer vector of offsets for the dates in `x`. The offsets are
#' relative to the day before 0001-01-01.
#' @noRd
.julian_date2offset <- function(x, leapyear) {
year1 <- x$year - 1L
corr <- ifelse(x$month <= 2L, 0L, as.integer(leapyear) - 2L)
365L * year1 + year1 %/% 4L + (367L * x$month - 362L) %/% 12L + corr + x$day - 2L
}
#' Offsets to dates, from function `julian-from-fixed()` and support functions.
#'
#' @param x Integer vector of offsets. The offsets must be relative to the day
#' before 0001-01-01.
#' @return `data.frame` with date elements "year", "month" and "day".
#' @noRd
.julian_offset2date <- function(x) {
yr <- (4 * (x + 1L) + 1464L) %/% 1461L
leapyear <- yr %% 4L == 0L
yr1 <- yr - 1L
jan1 <- -2L + 365L * yr1 + yr1 %/% 4L + 1L
prior_days <- x - jan1 + ifelse(x < jan1 + 59L + as.integer(leapyear), 0L, 2L - as.integer(leapyear))
mon <- (12L * prior_days + 373L) %/% 367L
day <- x - .julian_date2offset(data.frame(year = yr, month = mon, day = 1), leapyear) + 1L
data.frame(year = yr, month = mon, day = day)
}
|
