R/date.R

Defines functions date.mmddyyyy date.mmddyy date.ddmmmyy date.mdy mdy.date summary.date print.date print.date plot.date is.na.date as.vector.date as.character.date Summary.date Math.date Ops.date is.date as.date

Documented in as.character.date as.date as.vector.date date.ddmmmyy date.mdy date.mmddyy date.mmddyyyy is.date is.na.date Math.date mdy.date Ops.date plot.date print.date summary.date Summary.date

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 = "date")
	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 <- floor(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), as.character(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), as.character(NA),
           paste(temp$month, temp$day, tyr, sep = sep))
}
date.mmddyyyy <- function(sdate, sep = "/") {
    temp <- date.mdy(sdate)
    ifelse(is.na(sdate), as.character(NA),
           paste(temp$month, temp$day, temp$year, sep = sep))
}

Try the date package in your browser

Any scripts or data that you put into this service are public.

date documentation built on May 31, 2017, 3:19 a.m.