/
aweek-methods.R
272 lines (232 loc) · 8.62 KB
/
aweek-methods.R
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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
#' The aweek class
#'
#' The aweek class is a character or factor in the format YYYY-Www(-d) with a
#' "week_start" attribute containing an integer specifying which day of the ISO
#' 8601 week each week should begin.
#'
#' @param x an object of class `aweek`
#' @param ... a series of `aweek` objects, characters, or Dates, (unused in `print.aweek()`)
#' @param recursive,use.names parameters passed on to [unlist()]
#'
#' @return an object of class `aweek`
#'
#' @details Weeks differ in their start dates depending on context. The ISO
#' 8601 standard specifies that Monday starts the week
#' (<https://en.wikipedia.org/wiki/ISO_week_date>) while the US CDC uses
#' Sunday as the start of the week
#' (<https://wwwn.cdc.gov/nndss/document/MMWR_Week_overview.pdf>). For
#' example, MSF has varying start dates depending on country in order to
#' better coordinate response.
#'
#' While there are packages that provide conversion for ISOweeks and epiweeks,
#' these do not provide seamless conversion from dates to epiweeks with
#' non-standard start dates. This package provides a lightweight utility to
#' be able to convert each day.
#'
#' \subsection{Calculation of week numbers}{
#'
#' Week numbers are calculated in three steps:
#'
#' 1. Find the day of the week, relative to the week_start (d). The day of the
#' week (d) relative to the week start (s) is calculated using the ISO week
#' day (i) via `d = 1L + ((i + (7L - s)) %% 7L)`.
#' 2. Find the date that represents midweek (m). The date that represents
#' midweek is found by subtracting the day of the week (d) from 4 and
#' adding that number of days to the current date: `m = date + (4 - d)`.
#' 3. Find the week number (w) by counting the number of days since 1 January
#' to (m), and use integer division by 7: `w = 1L + ((m - yyyy-01-01) %/% 7)`
#'
#' For the weeks around 1 January, the year is determined by the week number.
#' If the month is January, but the week number is 52 or 53, then the year for
#' the week (YYYY) is the calendar year (yyyy) minus 1. However, if the month
#' is December, but the week number is 1, then the year for the week (YYYY) is
#' the calendar year (yyyy) plus 1.
#'
#' }
#' \subsection{Structure of the aweek object}{
#'
#' The aweek object is a character vector in either the precise ISO week
#' format (YYYY-Www-d) or imprecise ISO week format (YYYY-Www) with
#' a `week_start` attribute indicating which ISO week day the week begins.
#' The precise ISO week format can be broken down like this:
#'
#' - **YYYY** is an ISO week-numbering year, which is the year relative to
#' the week, not the day. For example, the date 2016-01-01 would be
#' represented as 2015-W53-5 (ISO week), because while the date is in the
#' year 2016, the week is still part of the final week of 2015.
#' - W**ww** is the week number, prefixed by the character "W". This ranges
#' from 01 to 52 or 53, depending on whether or not the year has 52 or 53
#' weeks.
#' - **d** is a digit representing the weekday where 1 represents the first
#' day of the week and 7 represents the last day of the week. #'
#' The attribute `week_start` represents the first day of the week as an ISO
#' week day. This defaults to 1, which is Monday. If, for example, an aweek
#' object represented weeks starting on Friday, then the `week_start`
#' attribute would be 5, which is Friday of the ISO week.
#'
#' Imprecise formats (YYYY-Www) are equivalent to the first day of the week.
#' For example, 2015-W53 and 2015-W53-1 will be identical when converted to
#' date.
#'
#' }
#'
#' @note when combining aweek objects together, you must ensure that they have
#' the same week_start attribute. You can use [change_week_start()] to adjust
#' it.
#'
#'
#' @export
#' @aliases aweek-class
#' @rdname aweek-class
#' @seealso [date2week()], [get_aweek()], [as.Date.aweek()], [change_week_start()]
#' @examples
#' d <- as.Date("2018-12-20") + 1:40
#' w <- date2week(d, week_start = "Sunday")
#' print(w)
#'
#' # subsetting acts as normal
#' w[1:10]
#'
#' # Combining multiple aweek objects will only work if they have the same
#' # week_start day
#' c(w[1], w[3], w[5], as.aweek(as.Date("2018-12-01"), week_start = "Sunday"))
#'
#' # differing week_start days will throw an error
#' mon <- date2week(as.Date("2018-12-01"), week_start = "Monday")
#' mon
#' try(c(w, mon))
#'
#' # combining Dates will be coerced to aweek objects under the same rules
#' c(w, Sys.Date())
#'
#' # truncated aweek objects will be un-truncated
#' w2 <- date2week(d[1:5], week_start = "Sunday", floor_day = TRUE)
#' w2
#' c(w[1:5], w2)
print.aweek <- function(x, ...) {
tmp <- week2date("2019-W08-1", attr(x, "week_start"))
cat(sprintf("<aweek start: %s>\n", format(tmp, "%A")))
y <- x
attr(x, "week_start") <- NULL
class(x) <- class(x)[class(x) != "aweek"]
NextMethod("print")
invisible(y)
}
#' @export
#' @param i index for subsetting an aweek object.
#' @rdname aweek-class
`[.aweek` <- function(x, i) {
cl <- oldClass(x)
ws <- attr(x, "week_start")
xx <- NextMethod("[")
attr(xx, "week_start") <- ws
oldClass(xx) <- cl
xx
}
#' @export
#' @rdname aweek-class
`[[.aweek` <- function(x, i) {
cl <- oldClass(x)
ws <- attr(x, "week_start")
xx <- NextMethod("[[")
attr(xx, "week_start") <- ws
oldClass(xx) <- cl
xx
}
#' @export
#' @param value a value to add or replace in an aweek object
#' @rdname aweek-class
`[<-.aweek` <- function(x, i, value) {
ws <- attr(x, "week_start")
cl <- oldClass(x)
if (inherits(value, "aweek")) {
if (ws != attr(value, "week_start")) {
stop("aweek objects must have the same week_start attribute")
}
}
if (inherits(value, "character")) {
value <- as.aweek(value, week_start = ws)
}
if (inherits(value, "factor")) {
value <- as.character(value)
stop_if_not_aweek_string(value)
value <- get_aweek(week = int_week(value),
year = int_year(value),
day = int_wday(value),
week_start = ws)
}
if (inherits(value, c("Date", "POSIXt"))) {
value <- date2week(value, week_start = ws)
}
if (!is.null(value) && all(is.na(value))) {
value <- as.aweek(as.character(value), week_start = ws)
}
if (!inherits(value, "aweek")) {
stop(sprintf("Cannot add an object of class '%s' to an aweek object",
paste(class(value), collapse = ", ")))
}
xx <- NextMethod("[")
attr(xx, "week_start") <- ws
oldClass(xx) <- cl
xx
}
#' @export
#' @rdname aweek-class
as.list.aweek <- function(x, ...) {
xx <- NextMethod("as.list")
xx <- lapply(xx, function(i, ws, cl){
attr(i, "week_start") <- ws
oldClass(i) <- cl
i
}, ws = attr(x, "week_start"), cl = oldClass(x))
xx
}
#' @export
#' @rdname aweek-class
trunc.aweek <- function(x, ...) {
if (inherits(x, "factor")) {
levels(x) <- gsub("\\-\\d", "", levels(x))
} else {
x <- gsub("\\-\\d", "", x)
}
x
}
#' @export
#' @rdname aweek-class
rep.aweek <- function(x, ...) {
ws <- attr(x, "week_start")
cl <- oldClass(x)
xx <- NextMethod("rep")
attr(xx, "week_start") <- ws
oldClass(xx) <- cl
xx
}
#' @export
#' @rdname aweek-class
c.aweek <- function(..., recursive = FALSE, use.names = TRUE) {
# Find all the aweek objects and test that they all have the same week_start
# attribute. Throw an error if this isn't true
the_dots <- list(...)
week_start <- get_week_start(the_dots[[1]])
aweeks <- vlogic(the_dots, inherits, "aweek")
identical_week_starts <- vapply(the_dots[aweeks], get_week_start, integer(1)) == week_start
if (!all(identical_week_starts)) {
stop("All aweek objects must have the same week_start attribute. Please use change_week_start() to adjust the week_start attribute if you wish to combine these objects.")
}
# Find all the dates and convert them to aweek objects
dates <- vlogic(the_dots, inherits, c("Date", "POSIXt"))
the_dots[dates] <- lapply(the_dots[dates], date2week, week_start = week_start)
# convert everything to characters and unlist them
res <- unlist(lapply(the_dots, as.character), recursive = recursive, use.names = FALSE)
date_chars <- grepl("[0-9]{4}-[0-9]{2}-[0-9]{2}", res, perl = TRUE)
res[date_chars] <- as.character(date2week(res[date_chars], week_start = week_start))
# convert the characters to aweek objects
out <- get_aweek(week = int_week(res),
year = int_year(res),
day = int_wday(res),
start = week_start,
week_start = week_start
)
names(out) <- names(res)
out
}