"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) }