as.date <- function(x, order = "mdy", ...) { if (inherits(x, "date")) x else if (inherits(x,"POSIXt")){ rval<-difftime(x,ISOdate(1960,1,1),units="days") structure(rval,class="date") } else if (is.character(x)) { order.vec <- switch(order, "ymd" = c(1, 2, 3), "ydm" = c(1, 3, 2), "mdy" = c(2, 3, 1), "myd" = c(2, 1, 3), "dym" = c(3, 1, 2), "dmy" = c(3, 2, 1), stop("Invalid value for `order' option")) nn <- length(x) temp <- .C("char_date", as.integer(nn), as.integer(order.vec), as.character(x), month =integer(nn), day = integer(nn), year = integer(nn), PACKAGE = "survival") month <- ifelse(temp$month < 1 | temp$month > 12, NA, temp$month) day <- ifelse(temp$day == 0, NA, temp$day) year <- ifelse(temp$year == 0, NA, temp$year) temp <- mdy.date(month, day, year, ...) } else if (is.numeric(x)) { temp <- floor(x) attr(temp, "class") <- "date" } else stop("Cannot coerce to date format") temp } is.date <- function(x) inherits(x, "date") Ops.date <- function(e1, e2) { ## Certain operation yield a date, others just give a number. In ## order to make plotting functions work well, we end up allowing ## most all numeric operations. if (missing(e2)) stop("Unary operations not meaningful for dates") if (.Generic == "&" || .Generic== "|") stop(paste("`", .Generic, "' not meaningful for dates", sep = "")) class(e1) <- NULL class(e2) <- NULL if (.Generic == "-") { if (.Method[2] == "" ) { ## subtract a constant from a date e1 <- as.integer(e1 - e2) class(e1) <- "date" e1 } else if ((.Method[1] == "Ops.date" && .Method[2] == "Ops.date") || (.Method[1] == "")) e1 - e2 else ## date - factor should fail stop("Invalid operation for dates") } else if (.Generic == "+") { if (.Method[1] == "" || .Method[2]=="") { ## add constant to a date e1 <- as.integer(e1 + e2); class(e1) <- "date" e1 } else e1 + e2 } else get(.Generic)(e1, e2) } Math.date <- function(...) stop("Invalid operation on dates") Summary.date <- function (..., na.rm = FALSE) { ok <- switch(.Generic, min = , max = , range = TRUE, FALSE) if (!ok) stop(paste(.Generic, "not defined for dates")) as.date(NextMethod(.Generic)) } "[.date" <- function(x, ..., drop = TRUE) { cl <- class(x) class(x) <- NULL x <- NextMethod("[") class(x) <- cl x } "[[.date" <- function(x, ..., drop = TRUE) { cl <- class(x) class(x) <- NULL x <- NextMethod("[[") class(x) <- cl x } as.character.date <- function(x, ...) { fun <- options()$print.date if (is.null(fun)) date.ddmmmyy(x) else get(fun)(x) } as.data.frame.date <- as.data.frame.vector as.vector.date <- function(x, mode = "any") { if (mode == "any" || mode == "character" || mode == "logical" || mode == "list") as.vector(as.character(x), mode) else as.vector(unclass(x), mode) } is.na.date <- function(x) { NextMethod(.Generic) } plot.date <- function(x, y, ..., axes, xaxt, xlab, ylab,log="", xlim = range(x, na.rm = TRUE), ylim = range(y, na.rm = TRUE), type="p") { if(missing(xlab)) xlab <- deparse(substitute(x)) if(missing(ylab)) ylab <- deparse(substitute(y)) class(x) <- NULL # after deparse(substitute()) if(!missing(axes) && !axes) # argument axes works plot(x, y, ..., axes = axes, xlab = xlab, ylab = ylab,log=log, xlim = xlim, ylim = ylim,type=type) else if(!missing(xaxt)) plot(x, y, ..., xaxt = xaxt, xlab = xlab, ylab = ylab,log=log, xlim = xlim, ylim = ylim,type=type) else { plot(x, y, ..., xaxt = "n", xlab = xlab, ylab = ylab,log=log, xlim = xlim, ylim = ylim,type=type) x <- c(x[!is.na(x)], xlim) # draws axis completely when # using xlim xd <- date.mdy(x) ## get default for n from par("lab") temp <- pretty(x, n = par("lab")[1]) delta <- temp[2] - temp[1] if(delta < 1) temp <- seq(min(x), max(x), 1) else if(delta > 182) { temp <- xd$year + (x - mdy.date(1, 1, xd$year))/365 ## get default for n from par("lab") temp <- pretty(temp, n = par("lab")[1]) temp <- mdy.date(1, 1, floor(temp)) + floor((temp %% 1) * 365) } axis(1, temp, as.character.date(temp), ...) } } print.date <- function(x, quote, prefix, ...) { if (missing(quote)) quote <- FALSE invisible(print(as.character(x), quote = quote)) } print.date <- function(x, quote, prefix, ...) { fun <- options()$print.date if (is.null(fun)) x <- date.ddmmmyy(x) else x <- get(fun)(x) if (missing(quote)) quote <- FALSE invisible(print(x, quote=quote)) } summary.date <- function(object, ...) { y <- as.character(range(object)) names(y) <- c("First ", "Last ") y } mdy.date <- function(month, day, year, nineteen = TRUE, fillday = FALSE, fillmonth = FALSE) { ## Get the Julian date, but centered a la SAS, i.e., Jan 1 1960 is ## day 0. Algorithm taken from Numerical Recipies. temp <- any((month != trunc(month)) | (day != trunc(day)) | (year != trunc(year))) if (!is.na(temp) && temp) { warning("Non integer input values were truncated in mdy.date") month <- trunc(month) day <- trunc(day) year <- trunc(year) } if (nineteen) year <- ifelse(year < 100, year + 1900, year) ## Force input vectors to be the same length, but in a way that ## gives an error if their lengths aren't multiples of each other. temp <- numeric(length(month + day + year)) month <- month + temp day <- day + temp year <- year + temp if (fillmonth) { temp <- is.na(month) month[temp] <- 7 day[temp] <- 1 } if (fillday) day[is.na(day)] <- 15 month[month < 1 | month > 12] <- NA day[day < 1] <- NA year[year == 0] <- NA # there is no year 0 year <- ifelse(year < 0, year + 1, year) tyear<- ifelse(month > 2, year, year - 1) tmon <- ifelse(month > 2, month + 1, month + 13) julian <- trunc(365.25 * tyear) + trunc(30.6001 * tmon) + day - 715940 ## Check for Gregorian calendar changeover on Oct 15, 1582 temp <- trunc(0.01 * tyear) save <- ifelse(julian >= -137774, julian + 2 + trunc(.25 * temp) - temp, julian) ## Check for invalid days (31 Feb, etc.) by calculating the Julian ## date of the first of the next month year <- ifelse(month == 12, year+1, year) month<- ifelse(month == 12, 1, month + 1) day <- 1 tyear<- ifelse(month > 2, year, year - 1) tmon <- ifelse(month > 2, month + 1, month + 13) julian <- trunc(365.25 * tyear) + trunc(30.6001 * tmon) + day - 715940 temp <- trunc(0.01 * tyear) save2<- ifelse(julian >= -137774, julian + 2 + trunc(.25 * temp) - temp, julian) temp <- as.integer(ifelse(save2 > save, save, NA)) attr(temp, "class") <- "date" temp } date.mdy <- function(sdate, weekday = FALSE) { ## Return the month, day, and year given a julian date attr(sdate, "class") <- NULL # Stop any propogation of methods sdate <- sdate + 2436935 # From SAS to Num Recipies base # point wday <- as.integer((sdate + 1) %% 7 +1) temp <- ((sdate - 1867216) -.25) / 36524.25 sdate <- ifelse(sdate >= 2299161, trunc(sdate+ 1 +temp - trunc(.25 * temp)), sdate) jb <- sdate + 1524 jc <- trunc(6680 + ((jb - 2439870) - 122.1) / 365.25) jd <- trunc(365.25 * jc) je <- trunc((jb - jd)/ 30.6001) day <- (jb - jd) - trunc(30.6001 * je) month <- as.integer(ifelse(je > 13, je - 13, je - 1)) year <- as.integer(ifelse(month > 2, jc - 4716, jc - 4715)) year <- as.integer(ifelse(year <= 0, year - 1, year)) if (weekday) list(month = month, day = day, year = year, weekday = wday) else list(month = month, day = day, year = year) } date.ddmmmyy <- function(sdate) { temp <- date.mdy(sdate) tyr <- ifelse(floor(temp$year/100) == 19, temp$year-1900, temp$year) month <- month.abb[temp$month] ifelse(is.na(sdate), "NA", paste(temp$day, month, tyr, sep = "")) } date.mmddyy <- function(sdate, sep = "/") { temp <- date.mdy(sdate) tyr <- ifelse(floor(temp$year / 100) == 19, temp$year - 1900, temp$year) ifelse(is.na(sdate), "NA", paste(temp$month, temp$day, tyr, sep = sep)) } date.mmddyyyy <- function(sdate, sep = "/") { temp <- date.mdy(sdate) ifelse(is.na(sdate), "NA", paste(temp$month, temp$day, temp$year, sep = sep)) }