# SCCS @(#)as.character.date.s	1.1 10/25/91
as.character.date <- function(x) {
     func <- .Options[["print.date"]]
     if (is.null(func))  date.ddmmmyy(x)
     else                (get(func))(x)
     }
# SCCS @(#)as.date.s	1.3 8/14/92
as.date <- function(x, order='mdy', ...) {
    if (inherits(x, "date")) x
    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))

	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
    }
#SCCS @(#)date.ddmmmyy.s	1.4 5/7/92
date.ddmmmyy <- function(sdate) {
    temp <- date.mdy(sdate)
    tyr <- ifelse(floor(temp$year/100)==19, temp$year-1900, temp$year)
    month <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep",
	       "Oct", "Nov", "Dec")[temp$month]
    ifelse(is.na(sdate), "NA", paste(temp$day, month, tyr, sep=""))
    }
#SCCS @(#)date.mdy.s	1.2  6/12/91
#
#  Return the month, day, and year given a julian date
#
date.mdy <- function(sdate, weekday=F) {
    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)
    }
#SCCS @(#)date.mmddyy.s	1.4  5/7/92
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))
    }
#SCCS %W%  %G%
date.mmddyyyy <- function(sdate, sep='/') {
    temp <- date.mdy(sdate)
    ifelse(is.na(sdate), "NA", paste(temp$month, temp$day, temp$year, sep=sep))
    }
# SCCS @(#)is.date.s    1.2  10/25/91
is.date <- function(x)  inherits(x, "date")
#SCCS @(#)is.na.date.s	1.1 10/25/91
is.na.date <- function(x) {
    class(x) <- NULL
    is.na(x)
    }
#SCCS @(#)mdy.date.s	1.2  6/12/91
#  Get the Julian date, but centered a la SAS, i.e., Jan 1 1960 is day 0.
#    Algorithm taken from Numerical Recipies.
#
mdy.date <- function (month, day, year, nineteen=T, fillday=F, fillmonth=F) {
    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 <- 0*(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
    }
# SCCS %W% %G%
plot.date <- function(x, y,..., xaxt, xlab, ylab) {
    class(x) <- NULL
    if (missing(xlab)) xlab <- deparse(substitute(x))
    if (missing(ylab)) ylab <- deparse(substitute(y))

    if (!missing(xaxt)) plot(x, y, ..., xaxt=xaxt, xlab=xlab, ylab=ylab)
    else {
	plot(x, y, ..., xaxt='n', xlab=xlab, ylab=ylab)
	x <- x[!is.na(x)]
	xd<- date.mdy(x)
	temp <- pretty(x,5)
	delta <- temp[2] - temp[1]
	if (delta <1)
	    temp <- seq(min(x), max(x), 1)
	else if (delta > 182) {   #try to do it in years
	    temp <- xd$year + (x - mdy.date(1,1,xd$year))/365
	    temp <- pretty(temp,5)
	    temp <- mdy.date(1, 1, floor(temp)) + floor((temp%%1)*365)
	    }

	xlim <- par("usr")[1:2]
	temp <- temp[temp>xlim[1] & temp<xlim[2]]
	axis(1, temp, as.character.date(temp))
	}
    }
# SCCS @(#)print.date.s	1.2 10/25/91
#  Various date operations

print.date <- function(x, quote, prefix) {
     func <- .Options[["print.date"]]
     if (is.null(func)) x <- date.ddmmmyy(x)
     else               x <- (get(func))(x)
     if (missing(quote)) quote<-F
     invisible(print.atomic(x,quote))
     }