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