a year class for xts

## class creation
.classes <- c("year")
#' default Constructor of the S3 class
#'
#' @export
year <- function(x) {
    structure(floor(x + .001*11/12) , class = .classes)
}

## coercion to year: always go via numeric

#' @export
as.year <- function(x, ...) UseMethod("as.year")

#' @export
as.year.default <- function(x, ...) as.year(as.numeric(x))

#' @export
as.year.numeric <- function(x, ...) {
  ## perche' qui fa questa cosa invece di chiamare year?
    structure(floor(x), class = .classes)
}

#' @export
as.year.integer <- function(x, ...) structure(x, class = .classes)

#' @export
as.yearqtr.year <- function(x, ...) as.yearqtr(as.Date.year(x), ...)

#' @export
as.yearmon.year<- function(x, ...) as.yearmon(as.Date.year(x), ...)

#' @export
as.year.Date <- function(x, ...) as.year(as.numeric(strftime(x, format="%Y")), ...)

#' @export
as.year.mondate <-
    as.year.jul <- # jul is in tis package
    as.year.timeDate <-
    as.year.dates <-
    as.year.POSIXt <- function(x, ...) as.POSIXlt(as.Date(x,...))

#' @export
seq.year <- function(from = NA, to=NA, by = 1, ...) {
    year(seq(from = as.numeric(from),
        to = as.numeric(to),
        by = by,
        ...))
}

#' @export
as.year.year <- function(x, ...) x

#' @export
as.year.factor <- function(x, ...) as.year(as.character(x), ...)

#' @export
as.year.character <- function(x, ...) as.year(as.numeric(x), ...)

#' @export
as.year.ti <- function(x, ...) as.year(as.Date(x), ...)

## coercion from year
## returned Date is the fraction of the way through the period given by frac

#' @export
#' @import lubridate
as.Date.year <- function(x, frac = 1, ...) {
  x <- unclass(x)
  if(all(is.na(x))) return(as.Date(x))
  y <- floor(x + .001)
  ix <- !is.na(y)
  month <- rep(floor(12 * frac), length(y))
  last.day.of.month <- function(iy, month) {
    feb <- 28
    if(leap_year(iy)) {
      feb <- 29
    }
    switch(paste(month),
           "2"=feb,
           "4"=,
           "6"=,
           "9"=,
           "11"=30,
           31)
  }
  last.day = rep(last.day.of.month(y[1], month[1]), length(y))
  last.day[is.na(y)] <- NA
  dd.start <- as.Date(rep(NA, length(y)))
  dd.start[ix] <- as.Date(paste(y[ix], month[ix], last.day, sep = '-'))
  dd.start
}

#' @export
as.POSIXct.year <- function(x, tz = "", ...) {
    as.POSIXct(as.Date(x), tz = tz, ...)
}

#' @export
as.year.POSIXlt <- 
as.year.POSIXct <- function(x, ...) {
  as.year(as.Date(x), ...)
}

#' @export
as.POSIXlt.year <- function(x, tz = "", ...) {
  as.POSIXlt(as.Date(x), tz = tz, ...)
}

                                        #' @export
as.list.year <- function(x, ...) lapply(seq_along(x), function(i) x[i])

#' @export
as.numeric.year <- function(x, ...) unclass(x)

#' @export
as.character.year <- function(x, ...) format.year(x, ...)

#' @export
as.data.frame.year <- 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 year
#' @export
c.year <- function(...) {
    as.year(do.call("c", lapply(list(...), as.numeric)))
}

#' @export
cycle.year <- function(x, ...) as.numeric(quarters(x))

#' @export
format.year <- function(x, format = "%Y", ...) {
    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.year(x)
    x <- unclass(x)
    year <- floor(x + .001)
    if (format == "%Y") return(paste(year))
    ## TODO: speed up the following
    xx <- gsub.vec("%Y", year, xx)
    xx <- gsub.vec("%y", sprintf("%02d", as.integer(year %% 100)), xx)
    xx <- gsub.vec("%C", year %/% 100, xx)
    names(xx) <- names(x)
    xx
}

#' @export
months.year <- function(x, abbreviate) {
  months(as.Date(x), abbreviate)
}

#' @export
quarters.year <- function(x, abbreviate) {
  quarters(as.Date(x), abbreviate)
}

#' @export
print.year <- function(x, ...) {
    print(format(x), ...)
    invisible(x)
}

#' @export
"[.year" <- function (x, ..., drop = TRUE)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[")
    class(val) <- cl
    val
}

#' @export
"[[.year" <- function (x, ..., drop = TRUE)
{
    cl <- oldClass(x)
    class(x) <- NULL
    val <- NextMethod("[[")
    class(val) <- cl
    val
}

#' @export
MATCH.year <- function(x, table, nomatch = NA, ...) {
  match(floor(
      as.numeric(x) + .001),
        floor(as.numeric(table) + .001), nomatch = nomatch, ...)
}

#' @export
Ops.year <- function(e1, e2) {
  e1 <- as.numeric(as.year(e1))
  e2 <- as.numeric(as.year(e2))
  rval <- NextMethod(.Generic)
  if(is.numeric(rval)) rval <- year(rval)
  return(rval)
}

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

#' @export
"+.year" <- function (e1, e2)
{
  if (!inherits(e1, "year"))
    stop("Can only add from year objects")
  if (nargs() == 1)
    return(as.numeric(e1))
  if (inherits(e2, "year"))
    return(as.numeric(e1) + as.numeric(e2))
  if (!is.null(attr(e2, "class")))
    stop("can only add year objects and numbers from year objects")
  year(unclass(e1) + e2)
}

#' @export
is.numeric.year <- function(x) FALSE

#' @export
Axis.year <- function(x = NULL, at = NULL, ..., side, labels = NULL)
  axis.year(x = x, at = at, ..., side = side, labels = TRUE)

#' @export
axis.year <- 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.year(at)
    } else {
        x <- as.year(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) <- "year"
    if (d > N1) { # axis has years only
        z <- structure(pretty(z), class = "year")
    } 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) <- "year"
    if (identical(labels, TRUE)) {
        if (missing(format)) {
            format <- c("%Y", "Q%q")
        }

        if (length(format) == 1) {
            format <- c(format, "")
        }

        if (d <= N2) {
            labels <- format.year(z, format = format[2])
        }

        idx <- format.year(z, format = "%q") == "1"
        labels <- rep(NA, length(z))
        labels[idx] <- format.year(z[idx], format = format[1])
    } else if (identical(labels, FALSE)) {
        labels <- rep("", length(z))
    }
    axis(side, at = z, labels = labels, ...)
}
#' @export
summary.year <- function(object, ...)
  summary(as.numeric(object), ...)

## convert from package date
#' @export
as.year.date <- function(x, ...) {
    as.year(as.Date(x, ...))
}

#' @export
mean.year <- function (x, ...) as.year(mean(unclass(x), ...))

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

#' @export
Sys.year <- function() as.year(Sys.Date())

#' @export
range.year <- function(..., na.rm = FALSE) {
    as.year(range.default(..., na.rm = na.rm))
}

#' @export
unique.year <- function(x, incomparables = FALSE, ...) {
    as.year(unique.default(x, incomparables = incomparables, ...))
}

#' @export
xtfrm.year <- function(x) as.numeric(x)