1#  File src/library/base/R/dates.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 1995-2020 The R Core Team
5#
6#  This program is free software; you can redistribute it and/or modify
7#  it under the terms of the GNU General Public License as published by
8#  the Free Software Foundation; either version 2 of the License, or
9#  (at your option) any later version.
10#
11#  This program is distributed in the hope that it will be useful,
12#  but WITHOUT ANY WARRANTY; without even the implied warranty of
13#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14#  GNU General Public License for more details.
15#
16#  A copy of the GNU General Public License is available at
17#  https://www.R-project.org/Licenses/
18
19## First shot at adding a "Date" class to base R.
20## Representation is the number of whole days since 1970-01-01.
21
22## The difftime class already covers time differences in days.
23
24## Need to take timezone into account here
25Sys.Date <- function() as.Date(as.POSIXlt(Sys.time()))
26
27as.Date <- function(x, ...) UseMethod("as.Date")
28
29as.Date.POSIXct <- function(x, tz = "UTC", ...)
30{
31    if(tz == "UTC") {
32        z <- floor(unclass(x)/86400)
33        attr(z, "tzone") <- NULL
34        .Date(z)
35    } else
36        as.Date(as.POSIXlt(x, tz = tz))
37}
38
39as.Date.POSIXlt <- function(x, ...) .Internal(POSIXlt2Date(x))
40
41as.Date.factor <- function(x, ...) as.Date(as.character(x), ...)
42
43
44as.Date.character <- function(x, format,
45                              tryFormats = c("%Y-%m-%d", "%Y/%m/%d"),
46                              optional = FALSE, ...)
47{
48    charToDate <- function(x) {
49	is.na(x) <- !nzchar(x) # PR#17909
50	xx <- x[1L]
51        if(is.na(xx)) {
52            j <- 1L
53            while(is.na(xx) && (j <- j+1L) <= length(x)) xx <- x[j]
54            if(is.na(xx)) f <- "%Y-%m-%d" # all NAs
55        }
56	if(is.na(xx))
57            strptime(x, f)
58        else {
59            for(ff in tryFormats)
60                if(!is.na(strptime(xx, ff, tz="GMT")))
61                    return(strptime(x, ff))
62            ## no success :
63            if(optional)
64                as.Date.character(rep.int(NA_character_, length(x)), "%Y-%m-%d")
65            else stop("character string is not in a standard unambiguous format")
66        }
67    }
68    res <- if(missing(format)) charToDate(x) else strptime(x, format, tz="GMT")
69    as.Date(res)
70}
71
72as.Date.numeric <- function(x, origin, ...)
73{
74    if(missing(origin)) {
75        if(!length(x))
76            return(.Date(numeric()))
77        if(!any(is.finite(x)))
78            return(.Date(x))
79        stop("'origin' must be supplied")
80    }
81    as.Date(origin, ...) + x
82}
83
84as.Date.default <- function(x, ...)
85{
86    if(inherits(x, "Date"))
87	x
88    else if(is.null(x))
89        .Date(numeric())
90    else if(is.logical(x) && all(is.na(x)))
91	.Date(as.numeric(x))
92    else
93	stop(gettextf("do not know how to convert '%s' to class %s",
94		      deparse1(substitute(x)),
95		      dQuote("Date")),
96	     domain = NA)
97}
98
99## ## Moved to package date
100## as.Date.date <- function(x, ...)
101## {
102##     if(inherits(x, "date")) {
103##         x <- (x - 3653) # origin 1960-01-01
104##         return(structure(x, class = "Date"))
105##     } else stop(gettextf("'%s' is not a \"date\" object",
106##                          deparse1(substitute(x)) ))
107## }
108
109## ## Moved to package chron
110## as.Date.dates <- function(x, ...)
111## {
112##     if(inherits(x, "dates")) {
113##         z <- attr(x, "origin")
114##         x <- trunc(as.numeric(x))
115##         if(length(z) == 3L && is.numeric(z))
116##             x  <- x + as.numeric(as.Date(paste(z[3L], z[1L], z[2L], sep="/")))
117##         return(structure(x, class = "Date"))
118##     } else stop(gettextf("'%s' is not a \"dates\" object",
119##                          deparse1(substitute(x)) ))
120## }
121
122format.Date <- function(x, ...)
123{
124    xx <- format(as.POSIXlt(x), ...)
125    names(xx) <- names(x)
126    xx
127}
128
129## keep in sync with  print.POSIX?t()  in ./datetime.R
130print.Date <- function(x, max = NULL, ...)
131{
132    if(is.null(max)) max <- getOption("max.print", 9999L)
133    if(max < length(x)) {
134	print(format(x[seq_len(max)]), max=max+1, ...)
135	cat(" [ reached 'max' / getOption(\"max.print\") -- omitted",
136	    length(x) - max, 'entries ]\n')
137    } else if(length(x))
138	print(format(x), max = max, ...)
139    else
140	cat(class(x)[1L], "of length 0\n")
141    invisible(x)
142}
143
144summary.Date <- function(object, digits = 12L, ...)
145{
146    x <- summary.default(unclass(object), digits = digits, ...)
147    if(m <- match("NA's", names(x), 0L)) {
148        NAs <- as.integer(x[m])
149        x <- x[-m]
150        attr(x, "NAs") <- NAs
151    }
152    .Date(x, c("summaryDefault", "table", oldClass(object)))
153}
154
155`+.Date` <- function(e1, e2)
156{
157    ## need to drop "units" attribute here
158    coerceTimeUnit <- function(x)
159        as.vector(round(switch(attr(x,"units"),
160                               secs = x/86400, mins = x/1440, hours = x/24,
161                               days = x, weeks = 7*x)))
162
163    if (nargs() == 1L) return(e1)
164    # only valid if one of e1 and e2 is a scalar.
165    if(inherits(e1, "Date") && inherits(e2, "Date"))
166        stop("binary + is not defined for \"Date\" objects")
167    if (inherits(e1, "difftime")) e1 <- coerceTimeUnit(e1)
168    if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
169    .Date(unclass(e1) + unclass(e2))
170}
171
172`-.Date` <- function(e1, e2)
173{
174    coerceTimeUnit <- function(x)
175        as.vector(round(switch(attr(x,"units"),
176                               secs = x/86400, mins = x/1440, hours = x/24,
177                               days = x, weeks = 7*x)))
178    if(!inherits(e1, "Date"))
179        stop("can only subtract from \"Date\" objects")
180    if (nargs() == 1L) stop("unary - is not defined for \"Date\" objects")
181    if(inherits(e2, "Date")) return(difftime(e1, e2, units="days"))
182    if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
183    if(!is.null(attr(e2, "class")))
184        stop("can only subtract numbers from \"Date\" objects")
185    .Date(unclass(as.Date(e1)) - e2)
186}
187
188Ops.Date <- function(e1, e2)
189{
190    if (nargs() == 1L)
191        stop(gettextf("unary %s not defined for \"Date\" objects", .Generic),
192             domain = NA)
193    boolean <- switch(.Generic, "<" =, ">" =, "==" =,
194                      "!=" =, "<=" =, ">=" = TRUE,
195                      FALSE)
196    if (!boolean)
197        stop(gettextf("%s not defined for \"Date\" objects", .Generic),
198             domain = NA)
199    ## allow character args to be coerced to dates
200    if (is.character(e1)) e1 <- as.Date(e1)
201    if (is.character(e2)) e2 <- as.Date(e2)
202    NextMethod(.Generic)
203}
204
205Math.Date <- function (x, ...)
206    stop(gettextf("%s not defined for \"Date\" objects", .Generic),
207         domain = NA)
208
209Summary.Date <- function (..., na.rm)
210{
211    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
212    if (!ok) stop(gettextf("%s not defined for \"Date\" objects", .Generic),
213                  domain = NA)
214    .Date(NextMethod(.Generic), oldClass(list(...)[[1L]]))
215}
216
217`[.Date` <- function(x, ..., drop = TRUE)
218{
219    .Date(NextMethod("["), oldClass(x))
220}
221
222`[[.Date` <- function(x, ..., drop = TRUE)
223{
224    .Date(NextMethod("[["), oldClass(x))
225}
226
227`[<-.Date` <- function(x, ..., value)
228{
229    if(!length(value)) return(x)
230    value <- unclass(as.Date(value))
231    .Date(NextMethod(.Generic), oldClass(x))
232}
233
234`length<-.Date` <- function(x, value)
235    .Date(NextMethod(), oldClass(x))
236
237as.character.Date <- function(x, ...) format(x, ...)
238
239as.data.frame.Date <- as.data.frame.vector
240
241as.list.Date <- function(x, ...)
242    lapply(unclass(x), .Date, oldClass(x))
243
244c.Date <- function(..., recursive = FALSE)
245    .Date(c(unlist(lapply(list(...),
246                          function(e) unclass(as.Date(e))))))
247
248mean.Date <- function (x, ...)
249    .Date(mean(unclass(x), ...))
250
251seq.Date <- function(from, to, by, length.out = NULL, along.with = NULL, ...)
252{
253    if (missing(from)) stop("'from' must be specified")
254    if (!inherits(from, "Date")) stop("'from' must be a \"Date\" object")
255        if(length(as.Date(from)) != 1L) stop("'from' must be of length 1")
256    if (!missing(to)) {
257        if (!inherits(to, "Date")) stop("'to' must be a \"Date\" object")
258        if (length(as.Date(to)) != 1L) stop("'to' must be of length 1")
259    }
260    if (!missing(along.with)) {
261        length.out <- length(along.with)
262    }  else if (!is.null(length.out)) {
263        if (length(length.out) != 1L) stop("'length.out' must be of length 1")
264        length.out <- ceiling(length.out)
265    }
266    status <- c(!missing(to), !missing(by), !is.null(length.out))
267    if(sum(status) != 2L)
268        stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")
269    if (missing(by)) {
270        from <- unclass(as.Date(from))
271        to <- unclass(as.Date(to))
272        res <- seq.int(from, to, length.out = length.out)
273        return(.Date(res))
274    }
275
276    if (length(by) != 1L) stop("'by' must be of length 1")
277    valid <- 0L
278    if (inherits(by, "difftime")) {
279        by <- switch(attr(by,"units"), secs = 1/86400, mins = 1/1440,
280                     hours = 1/24, days = 1, weeks = 7) * unclass(by)
281    } else if(is.character(by)) {
282        by2 <- strsplit(by, " ", fixed = TRUE)[[1L]]
283        if(length(by2) > 2L || length(by2) < 1L)
284            stop("invalid 'by' string")
285        valid <- pmatch(by2[length(by2)],
286                        c("days", "weeks", "months", "quarters", "years"))
287        if(is.na(valid)) stop("invalid string for 'by'")
288        if(valid <= 2L) {
289            by <- c(1, 7)[valid]
290            if (length(by2) == 2L) by <- by * as.integer(by2[1L])
291        } else
292            by <- if(length(by2) == 2L) as.integer(by2[1L]) else 1
293    } else if(!is.numeric(by)) stop("invalid mode for 'by'")
294    if(is.na(by)) stop("'by' is NA")
295
296    if(valid <= 2L) { # days or weeks
297        from <- unclass(as.Date(from))
298        if(!is.null(length.out))
299            res <- seq.int(from, by = by, length.out = length.out)
300        else {
301            to0 <- unclass(as.Date(to))
302            ## defeat test in seq.default
303            res <- seq.int(0, to0 - from, by) + from
304        }
305        res <- .Date(res)
306    } else {  # months or quarters or years
307        r1 <- as.POSIXlt(from)
308        if(valid == 5L) { # years
309            if(missing(to)) {
310                yr <- seq.int(r1$year, by = by, length.out = length.out)
311            } else {
312                to0 <- as.POSIXlt(to)
313                yr <- seq.int(r1$year, to0$year, by)
314            }
315            r1$year <- yr
316            res <- as.Date(r1)
317        } else { # months or quarters
318            if (valid == 4L) by <- by * 3
319            if(missing(to)) {
320                mon <- seq.int(r1$mon, by = by, length.out = length.out)
321            } else {
322                to0 <- as.POSIXlt(to)
323                mon <- seq.int(r1$mon, 12*(to0$year - r1$year) + to0$mon, by)
324            }
325            r1$mon <- mon
326            res <- as.Date(r1)
327        }
328    }
329    ## can overshoot
330    if (!missing(to)) {
331        to <- as.Date(to)
332        res <- if (by > 0) res[res <= to] else res[res >= to]
333    }
334    res
335}
336
337## *very* similar to cut.POSIXt [ ./datetime.R ] -- keep in sync!
338cut.Date <-
339    function (x, breaks, labels = NULL, start.on.monday = TRUE,
340              right = FALSE, ...)
341{
342    if(!inherits(x, "Date")) stop("'x' must be a date-time object")
343    x <- as.Date(x)
344
345    if (inherits(breaks, "Date")) {
346	breaks <- sort(as.Date(breaks))
347    } else if(is.numeric(breaks) && length(breaks) == 1L) {
348	## specified number of breaks
349    } else if(is.character(breaks) && length(breaks) == 1L) {
350	by2 <- strsplit(breaks, " ", fixed = TRUE)[[1L]]
351	if(length(by2) > 2L || length(by2) < 1L)
352	    stop("invalid specification of 'breaks'")
353	valid <-
354	    pmatch(by2[length(by2)],
355		   c("days", "weeks", "months", "years", "quarters"))
356	if(is.na(valid)) stop("invalid specification of 'breaks'")
357	start <- as.POSIXlt(min(x, na.rm=TRUE))
358	if(valid == 1L) incr <- 1L
359	if(valid == 2L) {		# weeks
360	    start$mday <- start$mday - start$wday
361	    if(start.on.monday)
362		start$mday <- start$mday + ifelse(start$wday > 0L, 1L, -6L)
363            start$isdst <- -1L
364	    incr <- 7L
365	}
366	if(valid == 3L) {		# months
367	    start$mday <- 1L
368            start$isdst <- -1L
369            maxx <- max(x, na.rm = TRUE)
370	    end <- as.POSIXlt(maxx)
371	    step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
372	    end <- as.POSIXlt(end + (31 * step * 86400))
373	    end$mday <- 1L
374            end$isdst <- -1L
375	    breaks <- as.Date(seq(start, end, breaks))
376            ## 31 days ahead could give an empty level, so
377	    lb <- length(breaks)
378	    if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
379	} else if(valid == 4L) {	# years
380	    start$mon <- 0L
381	    start$mday <- 1L
382            start$isdst <- -1L
383            maxx <- max(x, na.rm = TRUE)
384	    end <- as.POSIXlt(maxx)
385	    step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
386	    end <- as.POSIXlt(end + (366 * step * 86400))
387	    end$mon <- 0L
388	    end$mday <- 1L
389            end$isdst <- -1L
390	    breaks <- as.Date(seq(start, end, breaks))
391            ## 366 days ahead could give an empty level, so
392	    lb <- length(breaks)
393	    if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
394	} else if(valid == 5L) {	# quarters
395	    qtr <- rep(c(0L, 3L, 6L, 9L), each = 3L)
396	    start$mon <- qtr[start$mon + 1L]
397	    start$mday <- 1L
398            start$isdst <- -1L
399	    maxx <- max(x, na.rm = TRUE)
400	    end <- as.POSIXlt(maxx)
401	    step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
402	    end <- as.POSIXlt(end + (93 * step * 86400))
403	    end$mon <- qtr[end$mon + 1L]
404	    end$mday <- 1L
405            end$isdst <- -1L
406	    breaks <- as.Date(seq(start, end, paste(step * 3L, "months")))
407	    ## 93 days ahead could give an empty level, so
408	    lb <- length(breaks)
409	    if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
410	} else {
411	    start <- as.Date(start)
412	    if (length(by2) == 2L) incr <- incr * as.integer(by2[1L])
413	    maxx <- max(x, na.rm = TRUE)
414	    breaks <- seq(start, maxx + incr, breaks)
415	    breaks <- breaks[seq_len(1L+max(which(breaks <= maxx)))]
416	}
417    } else stop("invalid specification of 'breaks'")
418    res <- cut(unclass(x), unclass(breaks), labels = labels,
419	       right = right, ...)
420    if(is.null(labels)) {
421	levels(res) <-
422	    as.character(if (is.numeric(breaks)) x[!duplicated(res)]
423			 else breaks[-length(breaks)])
424    }
425    res
426}
427
428julian.Date <- function(x, origin = as.Date("1970-01-01"), ...)
429{
430    if(length(origin) != 1L) stop("'origin' must be of length one")
431    structure(unclass(x) - unclass(origin), "origin" = origin)
432}
433
434weekdays.Date <- function(x, abbreviate = FALSE)
435    format(x, ifelse(abbreviate, "%a", "%A"))
436
437months.Date <- function(x, abbreviate = FALSE)
438    format(x, ifelse(abbreviate, "%b", "%B"))
439
440quarters.Date <- function(x, ...)
441{
442    x <- as.POSIXlt(x)$mon %/% 3L
443    paste0("Q", x+1L)
444}
445
446## These only make sense for negative digits, but still ...
447round.Date <- function(x, ...)
448{
449    .Date(NextMethod(), oldClass(x))
450}
451
452## must avoid truncating forwards dates prior to 1970-01-01.
453trunc.Date <- function(x, ...)
454    round(x - 0.4999999)
455
456rep.Date <- function(x, ...)
457{
458    .Date(NextMethod(), oldClass(x))
459}
460
461diff.Date <- function (x, lag = 1L, differences = 1L, ...)
462{
463    ismat <- is.matrix(x)
464    xlen <- if (ismat) dim(x)[1L] else length(x)
465    if (length(lag) != 1L || length(differences) > 1L || lag < 1L || differences < 1L)
466        stop("'lag' and 'differences' must be integers >= 1")
467    if (lag * differences >= xlen)
468        return(.difftime(numeric(), units="days"))
469    r <- x
470    i1 <- -seq_len(lag)
471    if (ismat)
472        for (i in seq_len(differences)) r <- r[i1, , drop = FALSE] -
473            r[-nrow(r):-(nrow(r) - lag + 1L), , drop = FALSE]
474    else for (i in seq_len(differences))
475        r <- r[i1] - r[-length(r):-(length(r) - lag + 1L)]
476    r
477}
478
479## ---- additions in 2.6.0 -----
480
481is.numeric.Date <- function(x) FALSE
482
483## ---- additions in 2.8.0 -----
484
485split.Date <- function(x, f, drop = FALSE, ...)
486{
487    lapply(split.default(unclass(x), f, drop = drop, ...),
488           .Date, oldClass(x))
489}
490
491xtfrm.Date <- function(x) as.numeric(x)
492
493## Added in 3.5.0.
494
495.Date <- function(xx, cl = "Date") `class<-`(xx, cl)
496