The R Project SVN R-packages

"chron" <-
function(dates. = NULL, times. = NULL,
         format = c(dates = "m/d/y", times = "h:m:s"),
         out.format, origin.)
{
    if(is.null(format))
        format <- c(dates = "m/d/y", times = "h:m:s")
    if(missing(out.format)){
        if(is.character(format))
            out.format <- format
        else
            stop('must specify the "out.format" argument')
    }
    given <- c(dates = !missing(dates.), times = !missing(times.))
    if(is.null(default.origin <- getOption("chron.origin")))
        default.origin <- c(month = 1, day = 1, year = 1970)
    if(all(!given))
        ## dates and times missing
        return(structure(numeric(0),
                         format = format, origin = default.origin,
                         class = c("chron", "dates", "times")))
    if(inherits(dates., "dates")) {
        if(missing(origin.))
            origin. <- origin(dates.)
        else origin(dates.) <- origin.
    }
    else if(missing(origin.))
        origin. <- default.origin
    if(given["dates"] && !given["times"]) {
        ## presumably only dates
        if(missing(format) && inherits(dates., "dates"))
            format <- attr(dates., "format")
        fmt <- switch(mode(format),
                      character = ,
                      list = format[[1]],
                      name = ,
                      "function" = format,
                      NULL = c(dates = "m/d/y"),
                      stop("unrecognized format"))
        dts <- convert.dates(dates., format = fmt, origin = origin.)
        tms <- dts - floor(dts) 
    ## if dates include fractions of days create a full chron
        if(!all(is.na(tms)) && any(tms[!is.na(tms)] != 0))
            return(chron(dates. = floor(dts), times. = tms, format
                         = format, out.format = out.format, origin = 
                         origin.))
        ofmt <- switch(mode(out.format),
                       character = ,
                       list = out.format[[1]],
                       name = ,
                       "function" = out.format,
                       NULL = c(dates = "m/d/y"),
                       stop("invalid output format"))
        attr(dts, "format") <- ofmt
        attr(dts, "origin") <- origin.
        class(dts) <- c("dates", "times")
        names(dts) <- names(dates.)
        return(dts)
    }
    if(given["times"] && !given["dates"]) {
        ## only times
        if(missing(format) && inherits(times., "times")) {
            format <- attr(times., "format")
            if(!is.name(format))
                format <- rev(format)[[1]]
        }
        fmt <- switch(mode(format),
                      character = ,
                      list = rev(format)[[1]],
                      name = ,
                      "function" = format,
                      NULL = c(times = "h:m:s"),
                      stop("invalid times input format"))
        tms <- convert.times(times., fmt)
        ofmt <- switch(mode(out.format),
                       character = ,
                       list = rev(out.format)[[1]],
                       name = ,
                       "function" = out.format,
                       NULL = c(dates = "m/d/y"),
                       stop("invalid times output format"))
        attr(tms, "format") <- ofmt
        class(tms) <- "times"
        names(tms) <- names(times.)
        return(tms)
    }
    ## both dates and times 
    if(length(times.) != length(dates.))
        stop(paste(deparse(substitute(dates.)), "and",
                   deparse(substitute(times.)), "must have equal lengths"))
    if(missing(format)) {
        if(is.null(fmt.d <- attr(dates., "format")))
            fmt.d <- format[1]
        if(is.null(fmt.t <- attr(times., "format")))
            fmt.t <- format[2]
        if(mode(fmt.d) == "character" && mode(fmt.t) == "character")
            format <- structure(c(fmt.d, fmt.t),
                                names = c("dates", "times"))
        else {
            fmt.d <- if(is.name(fmt.d)) fmt.d else fmt.d[[1]]
            fmt.t <- if(is.name(fmt.t)) fmt.t else rev(fmt.t)[[1]]
            format <- list(dates = fmt.d, times = fmt.t)
        }
    }
    if(any(length(format) != 2, length(out.format) != 2))
        stop("misspecified chron format(s) length")
    if(all(mode(format) != c("character", "list")))
        stop("misspecified input format(s)")
    if(all(mode(out.format) != c("list", "character")))
        stop("misspecified output format(s)")
    dts <- convert.dates(dates., format = format[[1]], origin = origin.)
    tms <- convert.times(times., format = format[[2]])
    x <- unclass(dts) + unclass(tms)
    attr(x, "format") <- out.format
    attr(x, "origin") <- origin.
    class(x) <- c("chron", "dates", "times")
    nms <- paste(names(dates.), names(times.))
    if(length(nms) && any(nms != ""))
        names(x) <- nms
    return(x)
}

as.chron <- function(x, ...) UseMethod("as.chron")
as.chron.default <- function (x, ...)
{
    if (inherits(x, "chron"))
        return(x)
    if (is.character(x) || is.numeric(x))
        return(chron(x, ...))
    if (all(is.na(x)))
        return(x)
    stop("`x' cannot be coerced to a chron object")
}
as.chron.POSIXt <- function(x, offset = 0, ...)
{
    ## offset is in hours relative to GMT
    if (!inherits(x, "POSIXt")) stop("wrong method")
    x <- unclass(as.POSIXct(x)) + 60*round(60*offset)
    tm <- x %% 86400
    if (any(tm != 0))
        chron(dates. = x %/% 86400, times. = tm/86400, ...)
    else
        chron(dates. = x %/% 86400, ...)
}

"is.chron" <-
function(x)
    inherits(x, "chron")

as.data.frame.chron <- as.data.frame.vector

"convert.chron" <-
function(x, format = c(dates = "m/d/y", times = "h:m:s"), origin.,
         sep = " ", enclose = c("(", ")"), ...)
{
    if(is.null(x) || !as.logical(length(x)))
        return(numeric(length = 0))
    if(is.numeric(x))
        return(x)
    if(!is.character(x) && all(!is.na(x)))
        stop(paste("objects", deparse(substitute(x)), 
                   "must be numeric or character"))
    if(length(format) != 2)
        stop("format must have length==2")
    if(missing(origin.)
       && is.null(origin. <- getOption("chron.origin")))
        origin. <- c(month = 1, day = 1, year = 1970)
    if(any(enclose != ""))
        x <- substring(x, first = 2, last = nchar(x) - 1)
    str <- unpaste(x, sep = sep)
    dts <- convert.dates(str[[1]], format = format[[1]], origin = origin., 
                         ...)
    tms <- convert.times(str[[2]], format = format[[2]], ...)
    dts + tms
}

"format.chron" <-
function(x, format = att$format, origin. = att$origin, sep = " ",
         simplify, enclosed = c("(", ")"), ...)
{
    att <- attributes(x)
    if(missing(simplify))
        if(is.null(simplify <- getOption("chron.simplify")))
            simplify <- FALSE
    dts <- format.dates(x, format[[1]], origin = origin., simplify = 
                        simplify)
    tms <- format.times(x - floor(x), format[[2]], simplify = simplify)
    x <- paste(enclosed[1], dts, sep, tms, enclosed[2], sep = "")   
    ## output is a character object w.o class
    att$class <- att$format <- att$origin <- NULL
    attributes(x) <- att
    x
}

"new.chron" <-
function(x, new.origin = c(1, 1, 1970),
         shift = julian(new.origin[1], new.origin[2], new.origin[3],
         c(0, 0, 0)))
{
    cl <- class(x)
    class(x) <- NULL                    # get rid of "delim" attribute
    del <- attr(x, "delim")
    attr(x, "delim") <- NULL            # map formats
    format <- attr(x, "format")
    format[1] <- switch(format[1],
                        abb.usa = paste("m", "d", "y", sep = del[1]),
                        abb.world = paste("d", "m", "y", sep = del[1]),
                        abb.ansi = "ymd",
                        full.usa = "month day year",
                        full.world = "day month year",
                        full.ansi = "year month year",
                        format[1])
    if(length(format) == 2)
        format[2] <- switch(format[2],
                            military = "h:m:s",
                            format[2])
    attr(x, "format") <- format
    orig <- attr(x, "origin")
    if(is.null(orig)) {
        x <- x - shift
        attr(x, "origin") <- new.origin
    }
    ## (update origin after we assign the proper class!)
    ## deal with times as attributes 
    tms <- attr(x, "times")
    if(!is.null(tms)) {
        if(all(tms[!is.na(tms)] >= 1))
            tms <- tms/(24 * 3600)
        x <- x + tms
        class(x) <- c("chron", "dates", "times")
    }
    else class(x) <- c("dates", "times")
    x
}

print.chron <-
function(x, digits = NULL, quote = FALSE, prefix = "", sep = " ",
         enclosed = c("(", ")"), simplify, ...)
{
    if(!as.logical(length(x))) {
        cat("chron(0)\n")
        return(invisible(x))
    }
    if(missing(simplify) &&
       is.null(simplify <- getOption("chron.simplify")))
            simplify <- FALSE
    xo <- x
    x <- format.chron(x, sep = sep, enclosed = enclosed, simplify = 
                      simplify)
    print.default(x, quote = quote)
    invisible(xo)
}