R/yearqtr.R

Defines functions diff.yearqtr xtfrm.yearqtr unique.yearqtr range.yearqtr Sys.yearqtr as.yearqtr.date summary.yearqtr Axis.yearqtr is.numeric.yearqtr Ops.yearqtr MATCH.yearqtr print.yearqtr quarters.yearqtr months.yearqtr format.yearqtr cycle.yearqtr c.yearqtr as.data.frame.yearqtr as.character.yearqtr as.numeric.yearqtr as.list.yearqtr as.POSIXlt.yearqtr as.POSIXct.yearqtr as.Date.yearqtr as.yearqtr.ti as.yearqtr.character as.yearqtr.factor as.yearqtr.yearqtr as.yearqtr.POSIXt as.yearqtr.integer as.yearqtr.numeric as.yearqtr.default as.yearqtr yearqtr

Documented in as.character.yearqtr as.data.frame.yearqtr as.Date.yearqtr as.list.yearqtr as.numeric.yearqtr as.POSIXct.yearqtr as.POSIXlt.yearqtr as.yearqtr as.yearqtr.character as.yearqtr.date as.yearqtr.default as.yearqtr.factor as.yearqtr.integer as.yearqtr.numeric as.yearqtr.POSIXt as.yearqtr.yearqtr cycle.yearqtr c.yearqtr format.yearqtr is.numeric.yearqtr MATCH.yearqtr Ops.yearqtr print.yearqtr range.yearqtr summary.yearqtr Sys.yearqtr unique.yearqtr xtfrm.yearqtr yearqtr

## class creation
yearqtr <- function(x) structure(floor(4*x + .001)/4, class = "yearqtr")

## coercion to yearqtr: always go via numeric
as.yearqtr <- function(x, ...) UseMethod("as.yearqtr")
as.yearqtr.default <- function(x, ...) as.yearqtr(as.numeric(x))
as.yearqtr.numeric <- function(x, ...) structure(floor(4*x + .0001)/4, class = "yearqtr")
as.yearqtr.integer <- function(x, ...) structure(x, class = "yearqtr")

# as.jul.yearqtr <- function(x, ...) jul(as.Date(x, ...)) # jul is from tis
as.yearqtr.mondate <-
as.yearqtr.jul <- # jul is in tis package
as.yearqtr.timeDate <-
as.yearqtr.dates <-
as.yearqtr.Date <- 
as.yearqtr.POSIXt <- function(x, ...) as.yearqtr(as.yearmon(x))
as.yearqtr.yearqtr <- function(x, ...) x

as.yearqtr.factor <- function(x, ...) as.yearqtr(as.character(x), ...)
as.yearqtr.character <- function(x, format, ...) {
    non.na <- x[!is.na(x)]
    if (length(non.na) == 0) 
        return(structure(rep(NA, length(x)), class = "yearqtr"))
    if (missing(format) || format == "") {
        format <- if (all(regexpr("q", non.na) > 0))  { "%Y q%q"
        } else if (all(regexpr("Q", non.na) > 0)) { "%Y Q%q"
        } else "%Y-%q"
    }
    y <- if (regexpr("%[qQ]", format) > 0) {
        format <- sub("%q", "%m", format)
        y <- as.numeric(as.yearmon(x, format))
        m0 <- round(12 * (y %% 1))
        floor(y) + ifelse(m0 > 3, NA, m0/4)
    } else as.yearmon(x, format)
    as.yearqtr(y)
}
as.yearqtr.ti <- function(x, ...) as.yearqtr(as.Date(x), ...)

## coercion from yearqtr
# returned Date is the fraction of the way through the period given by frac
as.Date.yearqtr <- function(x, frac = 0, ...) {
  x <- unclass(x)
  if(all(is.na(x))) return(as.Date(x))
  year <- floor(x + .001)
  ix <- !is.na(year)
  month <- floor(12 * (x - year) + 1 + .5 + .001)
  dd.start <- as.Date(rep(NA, length(year)))
  dd.start[ix] <- as.Date(paste(year[ix], month[ix], 1, sep = "-")) 
  dd.end <- dd.start + 100 - as.numeric(format(dd.start + 100, "%d")) 
  as.Date((1-frac) * as.numeric(dd.start) + frac * as.numeric(dd.end), origin = "1970-01-01")
}
as.POSIXct.yearqtr <- function(x, tz = "", ...) as.POSIXct(as.Date(x), tz = tz, ...)
as.POSIXlt.yearqtr <- function(x, tz = "", ...) as.POSIXlt(as.Date(x), tz = tz, ...)
as.list.yearqtr <- function(x, ...) lapply(seq_along(x), function(i) x[i])
as.numeric.yearqtr <- function(x, ...) unclass(x)
as.character.yearqtr <- function(x, ...) format.yearqtr(x, ...)
as.data.frame.yearqtr <- function(x, row.names = NULL, optional = FALSE, ...) 
{
  nrows <- length(x)
  nm <- paste(deparse(substitute(x), width.cutoff = 500), collapse = " ")
  if (is.null(row.names)) {
    if (nrows == 0) 
        row.names <- character(0)
    else if(length(row.names <- names(x)) == nrows && !any(duplicated(row.names))) {
    }
    else if(optional) row.names <- character(nrows)
    else row.names <- seq_len(nrows)
  }
  names(x) <- NULL
  value <- list(x)
  if(!optional) names(value) <- nm
  attr(value, "row.names") <- row.names
  class(value) <- "data.frame"
  value
}


## other methods for class yearqtr
c.yearqtr <- function(...) {
    as.yearqtr(do.call("c", lapply(list(...), as.numeric)))
}

cycle.yearqtr <- function(x, ...) round(4 * (as.numeric(x) %% 1)) + 1

format.yearqtr <- function(x, format = "%Y Q%q", ...) 
{
  if (length(x) == 0) return(character(0))
  # like gsub but replacement and x may be vectors the same length
  gsub.vec <- function(pattern, replacement, x, ...) {
    y <- x
    for(i in seq_along(x)) {
      y[i] <- gsub(pattern, replacement[i], x[i], ...)
    }
    y
  }
  x <- as.yearqtr(x)
  x <- unclass(x)
  year <- floor(x + .001)
  qtr <- floor(4*(x - year) + 1 + .5 + .001)
  xx <- if (format == "%Y Q%q") {
    paste(year, " Q", qtr, sep = "")
  } else {
    # TODO: speed up the following
    xx <- gsub.vec("%q", qtr, rep.int(format, length(qtr)))
    xx <- gsub.vec("%Y", year, xx)
    xx <- gsub.vec("%y", sprintf("%02d", as.integer(year %% 100)), xx)
    xx <- gsub.vec("%C", year %/% 100, xx)
    xx
  }
  names(xx) <- names(x)
  xx[is.na(x)] <- NA_character_
  return(xx)
}


months.yearqtr <- function(x, abbreviate = FALSE) {
    months(as.Date(x), abbreviate = abbreviate)
}

quarters.yearqtr <- function(x, abbreviate = FALSE) {
    quarters(as.Date(x), abbreviate = abbreviate)
}


print.yearqtr <- function(x, ...) { 
    print(format(x), ...)
    invisible(x) 
}

"[.yearqtr" <- function (x, ..., drop = TRUE) 
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[")
    class(val) <- cl
    val
}

"[[.yearqtr" <- function (x, ..., drop = TRUE) 
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[[")
    class(val) <- cl
    val
}

MATCH.yearqtr <- function(x, table, nomatch = NA, ...)
    match(floor(4*as.numeric(x) + .001), floor(4*as.numeric(table) + .001), nomatch = nomatch, ...)

Ops.yearqtr <- function(e1, e2) {
    e1 <- as.numeric(as.yearqtr(e1))
    e2 <- as.numeric(as.yearqtr(e2))
    rval <- NextMethod(.Generic)
    if(is.numeric(rval)) rval <- yearqtr(rval)
    return(rval)
}


"-.yearqtr" <- function (e1, e2) 
{
    if (!inherits(e1, "yearqtr")) 
        stop("Can only subtract from yearqtr objects")
    if (nargs() == 1) 
	return(- as.numeric(e1))
    if (inherits(e2, "yearqtr")) 
        return(as.numeric(e1) - as.numeric(e2))
    if (!is.null(attr(e2, "class"))) 
      stop("can only subtract yearqtr objects and numbers from yearqtr objects")
    yearqtr(unclass(e1) - e2)
}

is.numeric.yearqtr <- function(x) FALSE

Axis.yearqtr <- function(x = NULL, at = NULL, ..., side, labels = NULL)
    axis.yearqtr(x = x, at = at, ..., side = side, labels = TRUE)


axis.yearqtr <- function (side, x, at, format, labels = TRUE, ..., N1 = 25, N2 = 7) {
    # If years in range > N1 then only years shown.  
    # If years in range > N2 then quarter ticks are not labelled.
    mat <- missing(at) || is.null(at)
    if (!mat) # at not missing
        x <- as.yearqtr(at)
    else x <- as.yearqtr(x)
    range <- par("usr")[if (side%%2) 
        1:2
    else 3:4]
    # range[1] <- ceiling(range[1])
    # range[2] <- floor(range[2])
    d <- range[2] - range[1]
    z <- c(range, x[is.finite(x)])
    class(z) <- "yearqtr"
    if (d > N1) { # axis has years only
        z <- structure(pretty(z), class = "yearqtr")
    } else if (d > N2) { # axis has all years and unlabelled quarters
        z <- seq(min(x), max(x), 0.25)
	# z <- seq(floor(min(x)), ceiling(max(x)))
    } else { # years and quarters
        z <- seq(min(x), max(x), 0.25)
    }
    if (!mat) 
        z <- x[is.finite(x)]
    z <- z[z >= range[1] & z <= range[2]]
    z <- sort(unique(z))
    class(z) <- "yearqtr"
    if (identical(labels, TRUE)) {
	if (missing(format)) format <- c("%Y", "Q%q")
	if (length(format) == 1) format <- c(format, "")
	if (d <= N2) labels <- format.yearqtr(z, format = format[2])
	idx <- format.yearqtr(z, format = "%q") == "1"
	labels <- rep(NA, length(z))
	labels[idx] <- format.yearqtr(z[idx], format = format[1])
    } else if (identical(labels, FALSE)) 
        labels <- rep("", length(z))
    axis(side, at = z, labels = labels, ...)
}

summary.yearqtr <- function(object, ...)
  summary(as.numeric(object), ...)

## convert from package date
as.yearqtr.date <- function(x, ...) {
	as.yearqtr(as.Date(x, ...))
}

mean.yearqtr <- function (x, ...) as.yearqtr(mean(unclass(x), ...))

Summary.yearqtr <- function (..., na.rm)
{
    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
    if (!ok) stop(.Generic, " not defined for yearqtr objects")
    val <- NextMethod(.Generic)
    class(val) <- oldClass(list(...)[[1]])
    val
}

Sys.yearqtr <- function() as.yearqtr(Sys.Date())

range.yearqtr <- function(..., na.rm = FALSE) {
	as.yearqtr(range.default(..., na.rm = na.rm))
}

unique.yearqtr <- function(x, incomparables = FALSE, ...) {
	as.yearqtr(unique.default(x, incomparables = incomparables, ...))
}

xtfrm.yearqtr <- function(x) as.numeric(x)

diff.yearqtr <- function(x, ...) as.numeric(NextMethod())

Try the zoo package in your browser

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

zoo documentation built on Sept. 18, 2022, 1:07 a.m.