home *** CD-ROM | disk | FTP | other *** search
/ Big Green CD 8 / BGCD_8_Dev.iso / NEXTSTEP / UNIX / Educational / R-0.49-MI / R-0.49-I / library / date < prev    next >
Encoding:
Text File  |  1997-09-14  |  6.0 KB  |  181 lines
  1. # SCCS @(#)as.character.date.s    1.1 10/25/91
  2. as.character.date <- function(x) {
  3.      func <- .Options[["print.date"]]
  4.      if (is.null(func))  date.ddmmmyy(x)
  5.      else                (get(func))(x)
  6.      }
  7. # SCCS @(#)as.date.s    1.3 8/14/92
  8. as.date <- function(x, order='mdy', ...) {
  9.     if (inherits(x, "date")) x
  10.     else if (is.character(x)) {
  11.     order.vec <- switch(order,
  12.                   'ymd'= c(1,2,3),
  13.                   'ydm'= c(1,3,2),
  14.                   'mdy'= c(2,3,1),
  15.                   'myd'= c(2,1,3),
  16.                   'dym'= c(3,1,2),
  17.                   'dmy'= c(3,2,1),
  18.                    stop("Invalid value for 'order' option"))
  19.     nn <- length(x)
  20.     temp <- .C("char_date", as.integer(nn),
  21.                   as.integer(order.vec),
  22.                   as.character(x),
  23.                   month=integer(nn),
  24.                   day = integer(nn),
  25.                   year= integer(nn))
  26.  
  27.     month <- ifelse(temp$month<1 | temp$month>12, NA, temp$month)
  28.     day   <- ifelse(temp$day==0, NA, temp$day)
  29.     year  <- ifelse(temp$year==0, NA, temp$year)
  30.  
  31.     temp <- mdy.date(month, day, year, ...)
  32.     }
  33.     else if (is.numeric(x)) {
  34.     temp <- floor(x)
  35.     attr(temp, 'class') <- 'date'
  36.     }
  37.     else stop("Cannot coerce to date format")
  38.     temp
  39.     }
  40. #SCCS @(#)date.ddmmmyy.s    1.4 5/7/92
  41. date.ddmmmyy <- function(sdate) {
  42.     temp <- date.mdy(sdate)
  43.     tyr <- ifelse(floor(temp$year/100)==19, temp$year-1900, temp$year)
  44.     month <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep",
  45.            "Oct", "Nov", "Dec")[temp$month]
  46.     ifelse(is.na(sdate), "NA", paste(temp$day, month, tyr, sep=""))
  47.     }
  48. #SCCS @(#)date.mdy.s    1.2  6/12/91
  49. #
  50. #  Return the month, day, and year given a julian date
  51. #
  52. date.mdy <- function(sdate, weekday=F) {
  53.     attr(sdate, "class") <- NULL   #Stop any propogation of methods
  54.     sdate <- sdate + 2436935  #From SAS to Num Recipies base point
  55.     wday <- as.integer((sdate+1)%%7 +1)
  56.     temp <- ((sdate-1867216) -.25) / 36524.25
  57.     sdate <- ifelse(sdate >=2299161, trunc(sdate+1+temp -trunc(.25*temp)),
  58.                        sdate)
  59.     jb <- sdate + 1524
  60.     jc <- trunc(6680 + ((jb-2439870)-122.1)/365.25)
  61.     jd <- trunc(365.25 * jc)
  62.     je <- trunc((jb-jd)/ 30.6001)
  63.     day <- (jb - jd) - trunc(30.6001*je)
  64.     month <- as.integer(ifelse(je>13, je-13, je-1))
  65.     year  <- as.integer(ifelse(month>2, jc-4716, jc-4715))
  66.     year  <- as.integer(ifelse(year <=0, year-1, year))
  67.     if (weekday) list(month=month, day=day, year=year, weekday=wday)
  68.     else         list(month=month, day=day, year=year)
  69.     }
  70. #SCCS @(#)date.mmddyy.s    1.4  5/7/92
  71. date.mmddyy <- function(sdate, sep='/') {
  72.     temp <- date.mdy(sdate)
  73.     tyr <- ifelse(floor(temp$year/100)==19, temp$year-1900, temp$year)
  74.     ifelse(is.na(sdate), "NA", paste(temp$month, temp$day, tyr, sep=sep))
  75.     }
  76. #SCCS %W%  %G%
  77. date.mmddyyyy <- function(sdate, sep='/') {
  78.     temp <- date.mdy(sdate)
  79.     ifelse(is.na(sdate), "NA", paste(temp$month, temp$day, temp$year, sep=sep))
  80.     }
  81. # SCCS @(#)is.date.s    1.2  10/25/91
  82. is.date <- function(x)  inherits(x, "date")
  83. #SCCS @(#)is.na.date.s    1.1 10/25/91
  84. is.na.date <- function(x) {
  85.     class(x) <- NULL
  86.     is.na(x)
  87.     }
  88. #SCCS @(#)mdy.date.s    1.2  6/12/91
  89. #  Get the Julian date, but centered a la SAS, i.e., Jan 1 1960 is day 0.
  90. #    Algorithm taken from Numerical Recipies.
  91. #
  92. mdy.date <- function (month, day, year, nineteen=T, fillday=F, fillmonth=F) {
  93.     temp <- any( (month != trunc(month)) | (day != trunc(day)) |
  94.          (year != trunc(year)))
  95.     if (!is.na(temp) && temp) {
  96.     warning("Non integer input values were truncated in mdy.date")
  97.     month <- trunc(month)
  98.     day <- trunc(day)
  99.     year <- trunc(year)
  100.     }
  101.     if (nineteen)  year <- ifelse(year <100, year+1900, year)
  102.  
  103.     # Force input vectors to be the same length, but in a way that gives an
  104.     #   error if their lengths aren't multiples of each other.
  105.     temp <- 0*(month + day + year)
  106.     month <- month + temp
  107.     day   <- day + temp
  108.     year  <- year + temp
  109.  
  110.     if (fillmonth) {
  111.     temp <- is.na(month)
  112.     month[temp] <- 7
  113.     day[temp] <- 1
  114.     }
  115.     if (fillday) day[is.na(day)] <- 15
  116.  
  117.  
  118.     month[month<1 | month>12] <- NA
  119.     day[day<1] <- NA
  120.     year[year==0] <- NA     #there is no year 0
  121.     year <- ifelse(year<0, year+1, year)
  122.     tyear<- ifelse(month>2, year, year-1)
  123.     tmon <- ifelse(month>2, month+1, month+13)
  124.  
  125.     julian <- trunc(365.25*tyear) + trunc(30.6001*tmon) + day - 715940
  126.     # Check for Gregorian calendar changeover on Oct 15, 1582
  127.     temp <- trunc(0.01 * tyear)
  128.     save <- ifelse(julian>=-137774, julian +2 + trunc(.25*temp) - temp, julian)
  129.  
  130.     #check for invalid days (31 Feb, etc.) by calculating the Julian date of
  131.     #    the first of the next month
  132.     year <- ifelse(month==12, year+1, year)
  133.     month<- ifelse(month==12, 1, month+1)
  134.     day <- 1
  135.     tyear<- ifelse(month>2, year, year-1)
  136.     tmon <- ifelse(month>2, month+1, month+13)
  137.     julian <- trunc(365.25*tyear) + trunc(30.6001*tmon) + day - 715940
  138.     temp <- trunc(0.01 * tyear)
  139.     save2<- ifelse(julian>=-137774, julian +2 + trunc(.25*temp) - temp, julian)
  140.     temp <-as.integer(ifelse(save2>save, save, NA))
  141.     attr(temp, "class") <- "date"
  142.     temp
  143.     }
  144. # SCCS %W% %G%
  145. plot.date <- function(x, y,..., xaxt, xlab, ylab) {
  146.     class(x) <- NULL
  147.     if (missing(xlab)) xlab <- deparse(substitute(x))
  148.     if (missing(ylab)) ylab <- deparse(substitute(y))
  149.  
  150.     if (!missing(xaxt)) plot(x, y, ..., xaxt=xaxt, xlab=xlab, ylab=ylab)
  151.     else {
  152.     plot(x, y, ..., xaxt='n', xlab=xlab, ylab=ylab)
  153.     x <- x[!is.na(x)]
  154.     xd<- date.mdy(x)
  155.     temp <- pretty(x,5)
  156.     delta <- temp[2] - temp[1]
  157.     if (delta <1)
  158.         temp <- seq(min(x), max(x), 1)
  159.     else if (delta > 182) {   #try to do it in years
  160.         temp <- xd$year + (x - mdy.date(1,1,xd$year))/365
  161.         temp <- pretty(temp,5)
  162.         temp <- mdy.date(1, 1, floor(temp)) + floor((temp%%1)*365)
  163.         }
  164.  
  165.     xlim <- par("usr")[1:2]
  166.     temp <- temp[temp>xlim[1] & temp<xlim[2]]
  167.     axis(1, temp, as.character.date(temp))
  168.     }
  169.     }
  170. # SCCS @(#)print.date.s    1.2 10/25/91
  171. #  Various date operations
  172.  
  173. print.date <- function(x, quote, prefix) {
  174.      func <- .Options[["print.date"]]
  175.      if (is.null(func)) x <- date.ddmmmyy(x)
  176.      else               x <- (get(func))(x)
  177.      if (missing(quote)) quote<-F
  178.      invisible(print.atomic(x,quote))
  179.      }
  180. library.dynam("date.so")
  181.