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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
# Internal functions
#
# The functions in this source file are for internal use only.
# ==============================================================================
# Offsets and timestamp formatting
#' Validate offsets passed into a CFTime instance
#'
#' Tests the `offsets` values. Throws an error if the argument contains `NA` values.
#'
#' @param offsets The offsets to test
#'
#' @returns logical. `TRUE` if the offsets are valid, throws an error otherwise.
#' @noRd
.validOffsets <- function(offsets) {
if (any(is.na(offsets))) stop("Offsets cannot contain `NA` values.", call. = FALSE)
TRUE
}
#' Formatting of time strings from time elements
#'
#' This is an internal function that should not generally be used outside of
#' the CFtime package.
#'
#' @param t A `data.frame` representing timestamps.
#'
#' @returns A vector of character strings with a properly formatted time. If any
#' timestamp has a fractional second part, then all time strings will report
#' seconds at milli-second precision.
#' @noRd
.format_time <- function(t) {
fsec <- t$second %% 1L
if (any(fsec > 0L)) {
paste0(sprintf("%02d:%02d:", t$hour, t$minute), ifelse(t$second < 10, "0", ""), sprintf("%.3f", t$second))
} else {
sprintf("%02d:%02d:%02d", t$hour, t$minute, t$second)
}
}
#' Do the time elements have time-of-day information?
#'
#' If any time information > 0, then `TRUE` otherwise `FALSE`.
#'
#' This is an internal function that should not generally be used outside of
#' the CFtime package.
#'
#' @param t A `data.frame` representing timestamps.
#'
#' @returns `TRUE` if any timestamp has time-of-day information, `FALSE` otherwise.
#' @noRd
.has_time <- function(t) {
any(t$hour > 0) || any(t$minute > 0) || any(t$second > 0)
}
#' Do formatting of timestamps with format specifiers
#'
#' @param ts `data.frame` of decomposed offsets.
#' @param tz Time zone character string.
#' @param format A character string with the format specifiers, or
#' "date" or "timestamp".
#' @returns Character vector of formatted timestamps.
#' @noRd
.format_format <- function(ts, tz, format) {
if (format == "") format <- "timestamp"
if (format == "timestamp" && sum(ts$hour, ts$minute, ts$second) == 0)
format <- "date"
if (format == "date") return(sprintf("%04d-%02d-%02d", ts$year, ts$month, ts$day))
else if (format == "timestamp") return(sprintf("%04d-%02d-%02d %s", ts$year, ts$month, ts$day, .format_time(ts)))
# Expand any composite specifiers
format <- stringr::str_replace_all(format, c("%F" = "%Y-%m-%d", "%R" = "%H:%M", "%T" = "%H:%M:%S"))
# Splice in timestamp values for specifiers
# nocov start
if (grepl("%b|%h", format[1])) {
mon <- strftime(ISOdatetime(2024, 1:12, 1, 0, 0, 0), "%b")
format <- stringr::str_replace_all(format, "%b|%h", mon[ts$month])
}
if (grepl("%B", format[1])) {
mon <- strftime(ISOdatetime(2024, 1:12, 1, 0, 0, 0), "%B")
format <- stringr::str_replace_all(format, "%B", mon[ts$month])
}
# nocov end
format <- stringr::str_replace_all(format, "%[O]?d", sprintf("%02d", ts$day))
format <- stringr::str_replace_all(format, "%e", sprintf("%2d", ts$day))
format <- stringr::str_replace_all(format, "%[O]?H", sprintf("%02d", ts$hour))
format <- stringr::str_replace_all(format, "%[O]?I", sprintf("%02d", ts$hour %% 12))
format <- stringr::str_replace_all(format, "%[O]?m", sprintf("%02d", ts$month))
format <- stringr::str_replace_all(format, "%[O]?M", sprintf("%02d", ts$minute))
format <- stringr::str_replace_all(format, "%p", ifelse(ts$hour < 12, "AM", "PM"))
format <- stringr::str_replace_all(format, "%S", sprintf("%02d", as.integer(ts$second)))
format <- stringr::str_replace_all(format, "%[E]?Y", sprintf("%04d", ts$year))
format <- stringr::str_replace_all(format, "%z", tz)
format <- stringr::str_replace_all(format, "%%", "%")
format
}
# ==============================================================================
# Other internal functions
#' Calculate time units in factors
#'
#' @param f factor. Factor as generated by `CFfactor()`.
#' @param cal `CFCalendar` instance of the `CFTime` instance.
#' @param upd numeric. Number of units per day, from the `CFt` environment.
#' @returns A vector as long as the number of levels in the factor.
#' @noRd
.factor_units <- function(f, cal, upd) {
period <- attr(f, "period")
cal_class <- class(cal)[1L]
res <- if (period == "day")
rep(1L, nlevels(f))
else if (cal_class == "CFCalendar360") {
rep(c(360L, 90L, 90L, 30L, 10L, 1L)[which(CFt$factor_periods == period)], nlevels(f))
} else {
if (attr(f, "era") > 0L) {
if (cal_class == "CFCalendar366") {
switch(period,
"year" = rep(366L, nlevels(f)),
"season" = c(91L, 92L, 92L, 91L)[as.integer(substr(levels(f), 2, 2))],
"quarter" = c(91L, 91L, 92L, 92L)[as.integer(levels(f))],
"month" = c(31L, 29L, 31L, 30L, 31L, 30L, 31L, 31L, 30L, 31L, 30L, 31L)[as.integer(levels(f))],
"dekad" = {
dk <- as.integer(substr(levels(f), 2L, 3L))
ifelse(dk %% 3L > 0L | dk %in% c(12L, 18L, 27L, 33L), 10L,
ifelse(dk %in% c(3L, 9L, 15L, 21L, 24L, 30L, 36L), 11L, 9L))
}
)
} else {
switch(period,
"year" = rep(365L, nlevels(f)),
"season" = c(90L, 92L, 92L, 91L)[as.integer(substr(levels(f), 2, 2))],
"quarter" = c(90L, 91L, 92L, 92L)[as.integer(substr(levels(f), 2, 2))],
"month" = c(31L, 28L, 31L, 30L, 31L, 30L, 31L, 31L, 30L, 31L, 30L, 31L)[as.integer(levels(f))],
"dekad" = {
dk <- as.integer(substr(levels(f), 2L, 3L))
ifelse(dk %% 3L > 0L | dk %in% c(12L, 18L, 27L, 33L), 10L,
ifelse(dk %in% c(3L, 9L, 15L, 21L, 24L, 30L, 36L), 11L, 8L))
}
)
}
} else { # not an era factor
switch(period,
"year" = ifelse(cal$leap_year(as.integer(levels(f))), 366L, 365L),
"season" = {
year <- as.integer(substr(levels(f), 1L, 4L))
season <- as.integer(substr(levels(f), 6L, 6L))
ifelse(cal$leap_year(year), c(91L, 92L, 92L, 91L)[season], c(90L, 92L, 92L, 91L)[season])
},
"quarter" = {
year <- as.integer(substr(levels(f), 1L, 4L))
qtr <- as.integer(substr(levels(f), 6L, 6L))
ifelse(cal$leap_year(year), c(91L, 91L, 92L, 92L)[qtr], c(90L, 91L, 92L, 92L)[qtr])
},
"month" = {
year <- as.integer(substr(levels(f), 1L, 4L))
month <- as.integer(substr(levels(f), 6L, 7L))
ifelse(cal$leap_year(year), c(31L, 29L, 31L, 30L, 31L, 30L, 31L, 31L, 30L, 31L, 30L, 31L)[month],
c(31L, 28L, 31L, 30L, 31L, 30L, 31L, 31L, 30L, 31L, 30L, 31L)[month])
},
"dekad" = {
year <- as.integer(substr(levels(f), 1L, 4L))
dk <- as.integer(substr(levels(f), 6L, 7L))
ifelse(dk %% 3L > 0L | dk %in% c(12L, 18L, 27L, 33L), 10L,
ifelse(dk %in% c(3L, 9L, 15L, 21L, 24L, 30L, 36L), 11L,
ifelse(cal$leap_year(year), 9L, 8L)))
}
)
}
}
res * upd
}
|
