aion coverage - 87.28%

Files
Source

# SUBSET
#' @include AllGenerics.R
NULL

# Extract ======================================================================
## [ ---------------------------------------------------------------------------
#' @export
#' @rdname subset
#' @aliases [,RataDie-method
setMethod(
  f = "[",
  signature = c(x = "RataDie"),
  function(x, i) {
    z <- methods::callNextMethod() # Method for `numeric`
    methods::initialize(x, z)
  }
)

#' @export
#' @rdname subset
#' @aliases [,TimeIntervals-method
setMethod(
  f = "[",
  signature = c(x = "TimeIntervals"),
  function(x, i) {
    id <- x@.Id[i]
    start <- x@.Start[i]
    end <- x@.End[i]
    methods::initialize(x, .Id = id, .Start = start, .End = end)
  }
)

#' @export
#' @rdname subset
#' @aliases [,TimeSeries-method
setMethod(
  f = "[",
  signature = c(x = "TimeSeries"),
  function(x, i, j, k, drop = FALSE) {
    z <- x@.Data
    time <- x@.Time

    z <- z[i, j, k, drop = drop]
    if (isTRUE(drop)) return(z)

    if (!missing(i)) {
      if (is.character(i)) i <- match(i, dimnames(x)[1L])
      time <- time[i]
    }

    methods::initialize(x, z, .Time = time)
  }
)

# Transpose ====================================================================
#' @export
#' @rdname flip
#' @aliases flip,TimeSeries-method
setMethod(
  f = "flip",
  signature = c(x = "TimeSeries"),
  function(x) {
    z <- x@.Data
    z <- fix_dimnames(z) # Fix dimnames (if needed)
    z <- aperm(z, perm = c(1, 3, 2), resize = TRUE)

    methods::initialize(x, z)
  }
)

# Window =======================================================================
#' @export
#' @method window TimeSeries
window.TimeSeries <- function(x, start = NULL, end = NULL, ...) {
  if (is.null(start)) start <- start(x)
  if (is.null(end)) end <- end(x)
  years <- time(x)

  i <- which(years >= start & years <= end)
  x[i, , , drop = FALSE]
}

#' @export
#' @rdname window
#' @aliases window,TimeSeries-method
setMethod("window", "TimeSeries", window.TimeSeries)

# CONVERT
#' @include AllGenerics.R
NULL

#' @export
#' @rdname convert
#' @aliases convert,character,character-method
setMethod(
  f = "convert",
  signature = c(from = "character", to = "character"),
  definition = function(from, to) {
    methods::callGeneric(from = calendar(from), to = calendar(to))
  }
)

#' @export
#' @rdname convert
#' @aliases convert,TimeScale,TimeScale-method
setMethod(
  f = "convert",
  signature = c(from = "TimeScale", to = "TimeScale"),
  definition = function(from, to) {
    ## TODO: validation

    fun <- function(x) {
      a <- fixed(x, month = 01, day = 01, calendar = from)
      b <- as_year(a, calendar = to, decimal = TRUE)
      return(b)
    }

    return(fun)
  }
)

# GREGORIAN CALENDAR
#' @include AllGenerics.R
NULL

# Fixed from Gregorian =========================================================
#' @export
#' @rdname fixed
#' @aliases fixed,numeric,missing,missing,GregorianCalendar-method
setMethod(
  f = "fixed",
  signature = c(year = "numeric", month = "missing", day = "missing", calendar = "GregorianCalendar"),
  definition = function(year, calendar, scale = 1) {
    ## Rescale to years (if not already)
    year <- year * scale

    rd <- fixed(year, 01, 01, calendar = calendar)

    is_leap <- which(is_gregorian_leap_year(year))
    rd[is_leap] <- ceiling(rd[is_leap]) # WHY ???
    rd
  }
)

#' @export
#' @rdname fixed
#' @aliases fixed,numeric,numeric,numeric,GregorianCalendar-method
setMethod(
  f = "fixed",
  signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "GregorianCalendar"),
  definition = function(year, month, day, calendar) {
    ## Recycle
    n <- length(year)
    if (n > 1) {
      if (length(month) == 1) month <- rep(month, n)
      if (length(day) == 1) day <- rep(day, n)
    }

    ## Switch origin
    year <- (year - calendar_epoch(calendar)) * calendar_direction(calendar)

    ## Correct for 28- or 29-day Feb
    correction <- rep(-2, length(year))
    correction[is_gregorian_leap_year(year)] <- -1
    correction[month <= 2] <- 0

    rd <- calendar_fixed(calendar) - 1 + # Days before start of calendar
      365 * (year - 1) +                 # Ordinary days since epoch
      (year - 1) %/% 4 -                 # Julian leap days since epoch minus...
      (year - 1) %/% 100 +               # ...century years since epoch plus...
      (year - 1) %/% 400 +               # ...years since epoch divisible by 400
      (367 * month - 362) %/% 12 +       # Days in prior months this year assuming 30-day Feb
      correction +                       # Correct for 28- or 29-day Feb
      day                                # Days so far this month.

    ## Fix infinite values
    rd[is.infinite(year)] <- year[is.infinite(year)]

    .RataDie(rd)
  }
)
# Gregorian from fixed =========================================================
#' @export
#' @rdname as_year
#' @aliases as_year,numeric,GregorianCalendar-method
setMethod(
  f = "as_year",
  signature = c(object = "numeric", calendar = "GregorianCalendar"),
  definition = function(object, calendar, decimal = TRUE, ...) {
    d0 <- object - calendar_fixed(calendar)
    n400 <- d0 %/% 146097
    d1 <- d0 %% 146097
    n100 <- d1 %/% 36524
    d2 <- d1 %% 36524
    n4 <- d2 %/% 1461
    d3 <- d2 %% 1461
    n1 <- d3 %/% 365

    year <- 400 * n400 + 100 * n100 + 4 * n4 + n1
    year <- ifelse(n100 == 4 | n1 == 4, year, year + 1)

    ## Shift origin
    year <- (year - calendar_epoch(calendar)) * calendar_direction(calendar)

    if (isTRUE(decimal)) {
      ## Year length in days
      start <- fixed(year, 01, 01, calendar = calendar)
      end <- fixed(year, 12, 31, calendar = calendar)
      total <- end - start + 1

      ## Elapsed time
      sofar <- object - start

      year <- year + sofar / total
    }

    ## Fix infinite values
    year[is.infinite(object)] <- object[is.infinite(object)]

    year
  }
)

#' @export
#' @rdname as_date
#' @aliases as_date,numeric,GregorianCalendar-method
setMethod(
  f = "as_date",
  signature = c(object = "numeric", calendar = "GregorianCalendar"),
  definition = function(object, calendar) {
    year <- as_year(object, calendar = calendar, decimal = FALSE)
    prior_days <- object - fixed(year, 01, 01, calendar = calendar)

    correction <- rep(2, length(object))
    correction[object < fixed(year, 03, 01, calendar = calendar)] <- 0
    correction[is_gregorian_leap_year(year)] <- 1

    month <- (12 * (prior_days + correction) + 373) %/% 367
    day <- object - fixed(year, month, 01, calendar = calendar) + 1

    data.frame(
      year = as.numeric(year),
      month = as.numeric(month),
      day = as.numeric(day)
    )
  }
)

# Era ==========================================================================
#' @export
#' @rdname fixed_gregorian
fixed_from_BP <- function(year, month, day) {
  if (missing(month) || missing(day)) fixed(year, calendar = BP())
  else fixed(year, month, day, calendar = BP())
}
#' @export
#' @rdname fixed_gregorian
fixed_to_BP <- function(object) {
  as_year(object, calendar = BP(), decimal = TRUE)
}

#' @export
#' @rdname fixed_gregorian
fixed_from_BC <- function(year, month, day) {
  if (missing(month) || missing(day)) fixed(year, calendar = BC())
  else fixed(year, month, day, calendar = BC())
}
#' @export
#' @rdname fixed_gregorian
fixed_to_BC <- function(object) {
  as_year(object, calendar = BC(), decimal = TRUE)
}

#' @export
#' @rdname fixed_gregorian
fixed_from_BCE <- function(year, month, day) {
  if (missing(month) || missing(day)) fixed(year, calendar = BCE())
  else fixed(year, month, day, calendar = BCE())
}
#' @export
#' @rdname fixed_gregorian
fixed_to_BCE <- function(object) {
  as_year(object, calendar = BCE(), decimal = TRUE)
}

#' @export
#' @rdname fixed_gregorian
fixed_from_AD <- function(year, month, day) {
  if (missing(month) || missing(day)) fixed(year, calendar = AD())
  else fixed(year, month, day, calendar = AD())
}
#' @export
#' @rdname fixed_gregorian
fixed_to_AD <- function(object) {
  as_year(object, calendar = AD(), decimal = TRUE)
}

#' @export
#' @rdname fixed_gregorian
fixed_from_CE <- function(year, month, day) {
  if (missing(month) || missing(day)) fixed(year, calendar = CE())
  else fixed(year, month, day, calendar = CE())
}
#' @export
#' @rdname fixed_gregorian
fixed_to_CE <- function(object) {
  as_year(object, calendar = CE(), decimal = TRUE)
}

#' @export
#' @rdname fixed_gregorian
fixed_from_b2k <- function(year, month, day) {
  if (missing(month) || missing(day)) fixed(year, calendar = b2k())
  else fixed(year, month, day, calendar = b2k())
}
#' @export
#' @rdname fixed_gregorian
fixed_to_b2k <- function(object) {
  as_year(object, calendar = b2k(), decimal = TRUE)
}

# SHOW

# Show =========================================================================
setMethod(
  f = "show",
  signature = "TimeScale",
  definition = function(object) {
    cal_name <- calendar_name(object)
    cal_label <- calendar_label(object)
    has_name <- length(cal_name) == 1 && nzchar(cal_name)
    has_label <- length(cal_label) == 1 && nzchar(cal_label)

    era <- ""
    if (has_name && has_label) {
      era <- sprintf("%s (%s): ", cal_name, cal_label)
    }

    if (calendar_direction(object) > 0) {
      msg <- tr_("%s%s counted forwards from %g")
    } else {
      msg <- tr_("%s%s counted backwards from %g")
    }
    msg <- sprintf(msg, era, calendar_unit(object), calendar_epoch(object))
    cat(trimws(msg), sep = "\n")
  }
)

setMethod(
  f = "show",
  signature = "RataDie",
  definition = function(object) {
    msg <- tr_("Rata die: number of days since 01-01-01 (Gregorian)")
    cat(msg, sep = "\n")
    methods::callGeneric(object@.Data)
  }
)

setMethod(
  f = "show",
  signature = "TimeSeries",
  definition = function(object) {
    n <- dim(object)
    k <- n[[2]] + n[[3]] - 1
    start <- format(as_fixed(start(object)))
    end <- format(as_fixed(end(object)))
    msg <- ngettext(k, "%d x %d x %d time series observed between %s and %s",
                    "%d x %d x %d time series observed between %s and %s")
    msg <- sprintf(msg, n[[1L]], n[[2L]], n[[3L]], start, end)
    cat(msg, sep = "\n")
  }
)

setMethod(
  f = "show",
  signature = "TimeIntervals",
  definition = function(object) {
    n <- length(object)
    start <- format(as_fixed(min(start(object))))
    end <- format(as_fixed(max(end(object))))
    msg <- ngettext(n, "%d time interval observed between %s and %s",
                    "%d time intervals observed between %s and %s")
    msg <- sprintf(msg, n, start, end)
    cat(msg, sep = "\n")
  }
)

# TIME SERIES
#' @include AllGenerics.R
NULL

# array ========================================================================
#' @export
#' @rdname series
#' @aliases series,array,RataDie,missing-method
setMethod(
  f = "series",
  signature = c(object = "array", time = "RataDie", calendar = "missing"),
  definition = function(object, time, names = NULL) {
    ## Validation
    arkhe::assert_length(time, NROW(object))

    ## Set the names of the series
    n <- dim(object)[[2L]]
    if (!is.null(names)) {
      arkhe::assert_length(names, n)
      dimnames(object)[[2L]] <- names
    }
    if (is.null(dimnames(object)[[2L]])) {
      dimnames(object)[[2L]] <- paste0("S", seq_len(n))
    }

    ## Chronological order
    i <- order(time, decreasing = FALSE)
    time <- time[i]
    object <- object[i, , , drop = FALSE]

    .TimeSeries(object, .Time = time)
  }
)

#' @export
#' @rdname series
#' @aliases series,array,numeric,TimeScale-method
setMethod(
  f = "series",
  signature = c(object = "array", time = "numeric", calendar = "TimeScale"),
  definition = function(object, time, calendar, scale = 1, names = NULL) {
    if (methods::is(time, "RataDie")) {
      msg <- tr_("%s is already expressed in rata die: %s is ignored.")
      warning(sprintf(msg, sQuote("time"), sQuote("calendar")), call. = FALSE)
    } else {
      time <- fixed(time, calendar = calendar, scale = scale)
    }
    methods::callGeneric(object = object, time = time, names = names)
  }
)

# matrix =======================================================================
#' @export
#' @rdname series
#' @aliases series,matrix,numeric,TimeScale-method
setMethod(
  f = "series",
  signature = c(object = "matrix", time = "numeric", calendar = "TimeScale"),
  definition = function(object, time, calendar, scale = 1, names = NULL) {
    x <- array(object, dim = c(dim(object), 1))
    rownames(x) <- rownames(object)
    colnames(x) <- colnames(object)
    methods::callGeneric(object = x, time = time, calendar = calendar,
                         scale = scale, names = names)
  }
)

#' @export
#' @rdname series
#' @aliases series,matrix,RataDie,missing-method
setMethod(
  f = "series",
  signature = c(object = "matrix", time = "RataDie", calendar = "missing"),
  definition = function(object, time, names = NULL) {
    x <- array(object, dim = c(dim(object), 1))
    colnames(x) <- colnames(object)
    methods::callGeneric(object = x, time = time, names = names)
  }
)

# numeric ======================================================================
#' @export
#' @rdname series
#' @aliases series,numeric,numeric,TimeScale-method
setMethod(
  f = "series",
  signature = c(object = "numeric", time = "numeric", calendar = "TimeScale"),
  definition = function(object, time, calendar, scale = 1, names = NULL) {
    object <- array(data = object, dim = c(length(object), 1, 1))
    methods::callGeneric(object = object, time = time, calendar = calendar,
                         scale = scale, names = names)
  }
)

#' @export
#' @rdname series
#' @aliases series,numeric,RataDie,missing-method
setMethod(
  f = "series",
  signature = c(object = "numeric", time = "RataDie", calendar = "missing"),
  definition = function(object, time, names = NULL) {
    object <- array(data = object, dim = c(length(object), 1, 1))
    methods::callGeneric(object = object, time = time, names = names)
  }
)

# data.frame ===================================================================
#' @export
#' @rdname series
#' @aliases series,data.frame,numeric,TimeScale-method
setMethod(
  f = "series",
  signature = c(object = "data.frame", time = "numeric", calendar = "TimeScale"),
  definition = function(object, time, calendar, scale = 1, names = NULL) {
    object <- data.matrix(object)
    methods::callGeneric(object = object, time = time, calendar = calendar,
                         scale = scale, names = names)
  }
)

#' @export
#' @rdname series
#' @aliases series,data.frame,RataDie,missing-method
setMethod(
  f = "series",
  signature = c(object = "data.frame", time = "RataDie", calendar = "missing"),
  definition = function(object, time, names = NULL) {
    object <- data.matrix(object)
    methods::callGeneric(object = object, time = time, names = names)
  }
)

# PLOT
#' @include AllGenerics.R
NULL

# Plot =========================================================================
#' @export
#' @method plot TimeIntervals
plot.TimeIntervals <- function(x, calendar = get_calendar(), groups = NULL,
                               sort = TRUE, decreasing = FALSE,
                               xlab = NULL, ylab = NULL,
                               main = NULL, sub = NULL,
                               ann = graphics::par("ann"), axes = TRUE,
                               frame.plot = axes,
                               panel.first = NULL, panel.last = NULL, ...) {
  ## Save calendar for further use, e.g. year_axis()
  assign("last_calendar", value = function(...) calendar, envir = the)

  ## Get data
  lab <- labels(x)
  int <- as.data.frame(x, calendar = calendar)
  k <- nrow(int)
  if (is.null(groups)) groups <- rep("", k)
  arkhe::assert_length(groups, k)

  ## Graphical parameters
  dots <- list(...)
  col <- make_par(dots, "col", k)
  lwd <- make_par(dots, "lwd", k)
  lty <- make_par(dots, "lty", k)

  ## Sort and split
  if (sort) {
    i <- order(groups, start(x), end(x), decreasing = decreasing)
  } else {
    i <- order(groups, decreasing = decreasing)
  }
  int <- int[i, , drop = FALSE]
  lab <- lab[i]
  f <- factor(x = lab, levels = unique(lab), ordered = TRUE)
  int <- split(x = int, f = f)
  col <- split(x = col[i], f = f)
  lwd <- split(x = lwd[i], f = f)
  lty <- split(x = lty[i], f = f)
  n <- length(int)

  ## Open new window
  grDevices::dev.hold()
  on.exit(grDevices::dev.flush(), add = TRUE)
  graphics::plot.new()

  ## Set plotting coordinates
  xlim <- xlim(x, calendar = calendar, finite = TRUE)
  ylim <- c(1, n)
  graphics::plot.window(xlim = xlim, ylim = ylim)

  ## Evaluate pre-plot expressions
  panel.first

  ## Plot
  for (i in seq_len(n)) {
    x0 <- int[[i]]$start
    x1 <- int[[i]]$end

    ## Fix infinite boundaries
    x0[is.infinite(x0)] <- graphics::par("usr")[[1L]]
    x1[is.infinite(x1)] <- graphics::par("usr")[[2L]]

    ## Draw segments
    graphics::segments(x0 = x0, x1 = x1, y0 = i, y1 = i,
                       col = col[[i]], lty = lty[[i]], lwd = lwd[[i]], lend = 1)
  }

  ## Evaluate post-plot and pre-axis expressions
  panel.last

  ## Construct Axis
  if (axes) {
    year_axis(side = 1, format = TRUE, calendar = calendar)
    graphics::axis(side = 2, at = seq_len(n), labels = names(int),
                   lty = 0, las = 1)
  }

  ## Plot frame
  if (frame.plot) {
    graphics::box()
  }

  ## Add annotation
  if (ann) {
    if (is.null(calendar)) {
      cal_lab <- expression(italic("rata die"))
    } else {
      cal_lab <- format(calendar)
    }
    xlab <- xlab %||% cal_lab
    graphics::title(main = main, sub = sub, xlab = xlab, ylab = ylab)
  }

  invisible(x)
}

#' @export
#' @rdname plot
#' @aliases plot,TimeIntervals,missing-method
setMethod("plot", c(x = "TimeIntervals", y = "missing"), plot.TimeIntervals)

#' @export
#' @method plot TimeSeries
plot.TimeSeries <- function(x, facet = c("multiple", "single"),
                            calendar = get_calendar(),
                            panel = graphics::lines, flip = FALSE, ncol = NULL,
                            xlab = NULL, ylab = NULL,
                            main = NULL, sub = NULL,
                            ann = graphics::par("ann"), axes = TRUE,
                            frame.plot = axes,
                            panel.first = NULL, panel.last = NULL, ...) {
  ## Validation
  facet <- match.arg(facet, several.ok = FALSE)

  ## Save calendar for further use, e.g. year_axis()
  assign("last_calendar", value = function(...) calendar, envir = the)

  n <- dim(x)[2L]

  if (facet == "multiple" && n > 1) {
    .plot_multiple(x, calendar = calendar, panel = panel, y_flip = flip,
                   n_col = ncol, xlab = xlab, ylab = ylab,
                   main = main, sub = sub, ann = ann, axes = axes,
                   frame.plot = frame.plot, panel.first = panel.first,
                   panel.last = panel.last, ...)
  } else {
    .plot_single(x, calendar = calendar, panel = panel,
                 xlab = xlab, ylab = ylab,
                 main = main, sub = sub,
                 ann = ann, axes = axes,
                 frame.plot = frame.plot, panel.first = panel.first,
                 panel.last = panel.last, ...)
  }

  invisible(x)
}

#' @export
#' @rdname plot
#' @aliases plot,TimeSeries,missing-method
setMethod("plot", c(x = "TimeSeries", y = "missing"), plot.TimeSeries)

#' Single Panel Plot
#'
#' @param x A [`TimeSeries-class`] object.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]).
#' @param panel A [`function`] in the form `function(x, y, ...)`
#'  which gives the action to be carried out in each panel of the display.
#'  The default is [graphics::lines()].
#' @param xlim,ylim A length-two [`numeric`] vector specifying the the x and y
#'  limits.
#' @param main A [`character`] string giving a main title for the plot.
#' @param sub A [`character`] string giving a subtitle for the plot.
#' @param ann A [`logical`] scalar: should the default annotation (title and x
#'  and y axis labels) appear on the plot?
#' @param axes A [`logical`] scalar: should axes be drawn on the plot?
#' @param frame.plot A [`logical`] scalar: should a box be drawn around the
#'  plot?
#' @param panel.first An an `expression` to be evaluated after the plot axes are
#'  set up but before any plotting takes place. This can be useful for drawing
#'  background grids.
#' @param panel.last An `expression` to be evaluated after plotting has taken
#'  place but before the axes, title and box are added.
#' @param ... Further parameters to be passed to `panel`
#'  (e.g. [graphical parameters][graphics::par]).
#' @return
#'  Called for its side-effects: it results in a graphic being displayed.
#'  Invisibly returns `x`.
#' @keywords internal
#' @noRd
.plot_single <- function(x, calendar, panel = graphics::lines,
                         xlab = NULL, ylab = NULL,
                         xlim = NULL, ylim = NULL,
                         main = NULL, sub = NULL,
                         ann = graphics::par("ann"), axes = TRUE,
                         frame.plot = axes,
                         panel.first = NULL, panel.last = NULL, ...) {
  n_series <- dim(x)[2L]
  n_dim <- dim(x)[3L]

  ## Graphical parameters
  dots <- list(...)
  col <- make_par(dots, "col", n = n_dim)
  bg <- make_par(dots, "bg", n = n_dim)
  pch <- make_par(dots, "pch", n = n_dim)
  cex <- make_par(dots, "cex", n = n_dim)
  lwd <- make_par(dots, "lwd", n = n_dim)
  lty <- make_par(dots, "lty", n = n_dim)

  ## Open new window
  grDevices::dev.hold()
  on.exit(grDevices::dev.flush(), add = TRUE)
  graphics::plot.new()

  ## Set plotting coordinates
  years <- time(x, calendar = calendar)
  xlim <- xlim %||% xlim(x, calendar = calendar)
  ylim <- ylim %||% range(x, na.rm = TRUE)
  graphics::plot.window(xlim = xlim, ylim = ylim)

  ## Evaluate pre-plot expressions
  panel.first

  ## Plot
  for (j in seq_len(n_series)) {
    for (k in seq_len(n_dim)) {
      params <- list(col = col[k], bg = bg[k], pch = pch[k],
                     cex = cex[k], lwd = lwd[k], lty = lty[k])
      dots <- utils::modifyList(dots, params)
      args <- c(list(x = years, y = x[, j = j, k = k, drop = TRUE]), dots)
      do.call(panel, args)
    }
  }

  ## Evaluate post-plot and pre-axis expressions
  panel.last

  ## Construct Axis
  if (axes) {
    year_axis(side = 1, format = TRUE, calendar = calendar)
    graphics::axis(side = 2, las = 1)
  }

  ## Plot frame
  if (frame.plot) {
    graphics::box()
  }

  ## Add annotation
  if (ann) {
    if (is.null(calendar)) {
      cal_lab <- expression(italic("rata die"))
    } else {
      cal_lab <- format(calendar)
    }
    xlab <- xlab %||% cal_lab
    graphics::title(main = main, sub = sub, xlab = xlab, ylab = ylab)
  }

  invisible(x)
}

#' Multiple Panels Plot
#'
#' @param x A [`TimeSeries-class`] object.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]).
#' @param panel A [`function`] in the form `function(x, y, ...)`
#'  which gives the action to be carried out in each panel of the display.
#'  The default is [graphics::lines()].
#' @param y_flip A [`logical`] scalar: should the y-axis (ticks and numbering)
#'  be flipped from side 2 (left) to 4 (right) from series to series?
#' @param y_fixed A [`logical`] scalar: should the y-scale be shared across
#'  all series?
#' @param ncol An [`integer`] specifying the number of columns to use.
#'  Defaults to 1 for up to 4 series, otherwise to 2.
#' @param main A [`character`] string giving a main title for the plot.
#' @param sub A [`character`] string giving a subtitle for the plot.
#' @param ann A [`logical`] scalar: should the default annotation (title and x
#'  and y axis labels) appear on the plot?
#' @param axes A [`logical`] scalar: should axes be drawn on the plot?
#' @param frame.plot A [`logical`] scalar: should a box be drawn around the
#'  plot?
#' @param panel.first An an `expression` to be evaluated after the plot axes are
#'  set up but before any plotting takes place. This can be useful for drawing
#'  background grids.
#' @param panel.last An `expression` to be evaluated after plotting has taken
#'  place but before the axes, title and box are added.
#' @param ... Further parameters to be passed to `panel`
#'  (e.g. [graphical parameters][graphics::par]).
#' @return
#'  Called for its side-effects: it results in a graphic being displayed.
#'  Invisibly returns `x`.
#' @keywords internal
#' @noRd
.plot_multiple <- function(x, calendar, panel = graphics::lines,
                           y_flip = TRUE, y_fixed = FALSE, n_col = NULL,
                           xlab = NULL, ylab = NULL,
                           main = NULL, sub = NULL,
                           ann = graphics::par("ann"), axes = TRUE,
                           frame.plot = axes,
                           panel.first = NULL, panel.last = NULL, ...) {

  panel <- match.fun(panel)
  n <- dim(x)[2L]
  m <- dim(x)[3L]
  n_seq <- seq_len(n)
  m_seq <- seq_len(m)
  if (is.null(n_col)) n_col <- if (n > 4) 2 else 1
  n_row <- ceiling(n / n_col)

  ## Graphical parameters
  ## Save and restore
  old_par <- graphics::par(
    mar = c(0, 5.1, 0, if (y_flip) 5.1 else 2.1),
    oma = c(6, 0, 5, 0),
    mfcol = c(n_row, n_col)
  )
  on.exit(graphics::par(old_par))

  dots <- list(...)
  cex.lab <- make_par(dots, "cex.lab")
  col.lab <- make_par(dots, "col.lab")
  font.lab <- make_par(dots, "font.lab")
  cex.axis <- make_par(dots, "cex.axis")
  col.axis <- make_par(dots, "col.axis")
  font.axis <- make_par(dots, "font.axis")
  cex.main <- make_par(dots, "cex.main")
  font.main <- make_par(dots, "font.main")
  col.main <- make_par(dots, "col.main")

  years <- time(x, calendar = calendar)
  xlim <- xlim(x, calendar = calendar)
  ylim <- if (y_fixed) range(x, na.rm = TRUE) else NULL
  ylabs <- ylab %||% labels(x) %||% paste("Series", n_seq, sep = " ")
  for (j in n_seq) {
    ## Plot
    xj <- x[, j, , drop = FALSE]
    .plot_single(xj, calendar = calendar, panel = panel,
                 xlim = xlim, ylim = ylim,
                 main = NULL, sub = NULL, ann = FALSE, axes = FALSE,
                 frame.plot = frame.plot,
                 panel.first = panel.first, panel.last = panel.last, ...)

    ## Construct Axis
    xaxt <- make_par(dots, "xaxt")
    yaxt <- make_par(dots, "yaxt")
    do_x <- (j %% n_row == 0 || j == n)
    y_side <- if (j %% 2 || !y_flip) 2 else 4
    if (axes) {
      if (do_x && xaxt != "n") {
        year_axis(side = 1, format = TRUE, calendar = calendar,
                  xpd = NA, cex.axis = cex.axis,
                  col.axis = col.axis, font.axis = font.axis)
      }
      if (yaxt != "n") {
        graphics::axis(side = y_side, xpd = NA, cex.axis = cex.axis,
                       col.axis = col.axis, font.axis = font.axis, las = 1)
      }
    }

    ## Add annotation
    if (ann) {
      if (do_x) {
        cal_lab <- if (is.null(calendar)) expression(italic("rata die")) else format(calendar)
        xlab <- xlab %||% cal_lab
        graphics::mtext(xlab, side = 1, line = 3, cex = cex.lab, col = col.lab,
                        font = font.lab)
      }
      graphics::mtext(ylabs[[j]], side = y_side, line = 3, cex = cex.lab,
                      col = col.lab, font = font.lab)
    }
  }

  ## Add annotation
  if (ann) {
    graphics::par(mfcol = c(1, 1))
    graphics::mtext(main, side = 3, line = 3, cex = cex.main, font = font.main,
                    col = col.main)
  }

  invisible(x)
}

#' Compute x Limits
#'
#' Computes x limits for a time series according to a given calendar.
#' This ensures that the x axis is always in chronological order.
#' @param x A [`TimeSeries-class`] object.
#' @param calendar A [`TimeScale-class`] object.
#' @param finite A [`logical`] scalar: should non-finite elements be omitted?
#' @return A length-two [`numeric`] vector.
#' @keywords internal
#' @noRd
xlim <- function(x, calendar, finite = FALSE) {
  if (methods::is(x, "TimeSeries")) x <- time(x, calendar = NULL)
  if (methods::is(x, "TimeIntervals")) x <- c(start(x, calendar = NULL), end(x, calendar = NULL))
  x <- range(x, finite = finite)
  if (is.null(calendar)) return(x)
  as_year(x, calendar = calendar)
}

# Image ========================================================================
#' @export
#' @method image TimeSeries
image.TimeSeries <- function(x, calendar = get_calendar(), k = 1, ...) {
  ## Save calendar for further use, e.g. year_axis()
  assign("last_calendar", value = function(...) calendar, envir = the)

  ## Get data
  n <- seq_len(NCOL(x))
  samples <- labels(x) %||% paste0("S1", n)
  years <- time(x, calendar = NULL)

  ## Graphical parameters
  cex.axis <- list(...)$cex.axis %||% graphics::par("cex.axis")
  col.axis <- list(...)$col.axis %||% graphics::par("col.axis")
  font.axis <- list(...)$font.axis %||% graphics::par("font.axis")

  ## Save and restore
  mar <- graphics::par("mar")
  mar[2] <- inch2line(samples, cex = cex.axis) + 0.5
  old_par <- graphics::par(mar = mar)
  on.exit(graphics::par(old_par))

  ## Plot
  z <- x[, , k = k, drop = TRUE]
  graphics::image(x = years, y = n, z = z,
                  xlab = format(calendar), ylab = "",
                  xaxt = "n", yaxt = "n", ...)

  ## Construct axes
  at <- as_fixed(graphics::axTicks(side = 1))
  at <- pretty(at, calendar = calendar)
  lab <- format(at, label = FALSE, calendar = calendar)
  graphics::axis(side = 1, at = at, labels = lab)
  graphics::axis(side = 2, at = n, labels = samples,
                 cex.axis = cex.axis, las = 1,
                 col.axis = col.axis, font.axis = font.axis)

  invisible(x)
}

#' @export
#' @rdname image
#' @aliases image,TimeSeries-method
setMethod("image", c(x = "TimeSeries"), image.TimeSeries)

# GRAPH
#' @include AllGenerics.R
NULL

# S3 class as S4 ===============================================================
setClass("igraph")

# Create =======================================================================
#' @export
#' @rdname graph_create
#' @aliases graph_create,data.frame-method
setMethod(
  f = "graph_create",
  signature = c(object = "data.frame"),
  definition = function(object, type = c("interval", "stratigraphy"),
                        direction = c("above", "below"),
                        verbose = getOption("aion.verbose"), ...) {
    ## Coerce to character matrix
    object[] <- lapply(X = object, FUN = as.character)
    object <- as.matrix(object)

    methods::callGeneric(object, type = type, direction = direction,
                         verbose = verbose, ...)
  }
)

#' @export
#' @rdname graph_create
#' @aliases graph_create,matrix-method
setMethod(
  f = "graph_create",
  signature = c(object = "matrix"),
  definition = function(object, type = c("interval", "stratigraphy"),
                        direction = c("above", "below"),
                        verbose = getOption("aion.verbose"), ...) {
    ## Validation
    arkhe::assert_package("igraph")
    arkhe::assert_type(object, "character")
    arkhe::assert_dim(object, c(nrow(object), 2L))
    type <- match.arg(type, several.ok = FALSE)
    direction <- match.arg(direction, several.ok = FALSE)

    ## Remove singletons
    object <- arkhe::discard_rows(object, f = anyNA, verbose = verbose)

    ## Graph type
    if (identical(type, "interval")) directed <- FALSE
    if (identical(type, "stratigraphy")) directed <- TRUE

    ## Switch relations, if needed
    ## (does not matter if type == "interval")
    if (identical(direction, "below")) {
      object <- object[, c(2, 1)]
    }

    ## Reorder
    object <- object[order(object[, 1], object[, 2]), ]

    ## Create graph
    graph <- igraph::graph_from_edgelist(el = object, directed = directed)

    ## Check
    if (identical(type, "interval")) assert_graph_chordal(graph)
    if (identical(type, "stratigraphy")) assert_graph_dag(graph)

    graph
  }
)

#' @export
#' @rdname graph_create
#' @aliases graph_create,TimeIntervals-method
setMethod(
  f = "graph_create",
  signature = c(object = "TimeIntervals"),
  definition = function(object, type = c("interval", "stratigraphy"),
                        verbose = getOption("aion.verbose"), ...) {
    ## Validation
    type <- match.arg(type, several.ok = FALSE)

    ## Detect relations
    rel <- switch(
      type,
      interval = rbind(overlaps(object), finishes(object), contains(object),
                       starts(object), equals(object)),
      stratigraphy = rbind(preceded_by(object), met_by(object))
    )

    methods::callGeneric(rel, type = type, direction = "above",
                         verbose = verbose, ...)
  }
)

# Prune ========================================================================
#' @export
#' @rdname graph_prune
#' @aliases graph_prune,igraph-method
setMethod(
  f = "graph_prune",
  signature = c(object = "igraph"),
  definition = function(object, reduce = TRUE,
                        remove_multiple = TRUE, remove_loops = TRUE, ...) {

    ## Transitive reduction
    if (isTRUE(reduce) && isTRUE(igraph::is_dag(object))) {
      arkhe::assert_package("relations")

      edges <- as.matrix(object, matrix.type = c("edgelist"))
      endo <- relations::endorelation(
        # domain = lapply(unique(as.character(edges)), sets::as.set),
        graph = as.data.frame(edges)
      )
      red <- relations::transitive_reduction(endo)
      mat <- relations::relation_incidence(red)
      object <- igraph::graph_from_adjacency_matrix(mat, mode = "directed")
    }

    ## Remove multiple edges and loop edges
    if (isTRUE(remove_multiple) || isTRUE(remove_loops)) {
      object <- igraph::simplify(
        object,
        remove.multiple = remove_multiple,
        remove.loops = remove_loops
      )
    }

    object
  }
)

# Check ========================================================================
## Check if DAG
assert_graph_dag <- function(x, must_fail = FALSE) {
  is_dag <- igraph::is_dag(x)
  if (!isTRUE(is_dag)) {
    msg <- tr_("This is not a stratigraphic graph!")
    do <- if (isTRUE(must_fail)) stop else warning
    do(msg, "\n", tr_("This is not a directed acyclic graph."), call. = FALSE)
  }
  invisible(x)
}

## Check that there are no cycles with more than three nodes
assert_graph_chordal <- function(x, must_fail = FALSE) {
  is_chordal <- igraph::is_chordal(x)$chordal
  if (!isTRUE(is_chordal)) {
    msg <- tr_("This is not an interval graph!")
    do <- if (isTRUE(must_fail)) stop else warning
    do(msg, "\n", tr_("This is not a chordal graph."), call. = FALSE)
  }
  invisible(x)
}

# TEMPORAL RELATIONS
#' @include AllGenerics.R
NULL

# Precede ======================================================================
#' @export
#' @rdname relations
#' @aliases precedes,TimeIntervals-method
setMethod(
  f = "precedes",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .precedes,
      labels = labels(x),
      ...
    )
  }
)

.precedes <- function(xmin, xmax, ymin, ymax) {
  xmin < ymin & xmax < ymin
}

#' @export
#' @rdname relations
#' @aliases preceded_by,TimeIntervals,missing-method
setMethod(
  f = "preceded_by",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .preceded_by,
      labels = labels(x),
      ...
    )
  }
)

.preceded_by <- function(xmin, xmax, ymin, ymax) {
  xmin > ymax
}

# Meet =========================================================================
#' @export
#' @rdname relations
#' @aliases meets,TimeIntervals-method
setMethod(
  f = "meets",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .meets,
      labels = labels(x),
      ...
    )
  }
)

.meets <- function(xmin, xmax, ymin, ymax) {
  xmin < ymin & xmax == ymin
}

#' @export
#' @rdname relations
#' @aliases met_by,TimeIntervals,missing-method
setMethod(
  f = "met_by",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .met_by,
      labels = labels(x),
      ...
    )
  }
)

.met_by <- function(xmin, xmax, ymin, ymax) {
  xmin == ymax
}

# Overlap ======================================================================
#' @export
#' @rdname relations
#' @aliases overlaps,TimeIntervals-method
setMethod(
  f = "overlaps",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .overlaps,
      labels = labels(x),
      ...
    )
  }
)

.overlaps <- function(xmin, xmax, ymin, ymax) {
  xmin < ymin & xmax > ymin & xmax < ymax
}

#' @export
#' @rdname relations
#' @aliases overlapped_by,TimeIntervals,missing-method
setMethod(
  f = "overlapped_by",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .overlapped_by,
      labels = labels(x),
      ...
    )
  }
)

.overlapped_by <- function(xmin, xmax, ymin, ymax) {
  xmin > ymin & xmin < ymax & xmax > ymax
}

# Finish =======================================================================
#' @export
#' @rdname relations
#' @aliases finishes,TimeIntervals,missing-method
setMethod(
  f = "finishes",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .finishes,
      labels = labels(x),
      ...
    )
  }
)

.finishes <- function(xmin, xmax, ymin, ymax) {
  xmin > ymin & xmax == ymax
}

#' @export
#' @rdname relations
#' @aliases finished_by,TimeIntervals-method
setMethod(
  f = "finished_by",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .finished_by,
      labels = labels(x),
      ...
    )
  }
)

.finished_by <- function(xmin, xmax, ymin, ymax) {
  xmin < ymin & xmax == ymax
}

# Contain ======================================================================
#' @export
#' @rdname relations
#' @aliases contains,TimeIntervals-method
setMethod(
  f = "contains",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .contains,
      labels = labels(x),
      ...
    )
  }
)

.contains <- function(xmin, xmax, ymin, ymax) {
  xmin < ymin & xmax > ymax
}

#' @export
#' @rdname relations
#' @aliases during,TimeIntervals,missing-method
setMethod(
  f = "during",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .during,
      labels = labels(x),
      ...
    )
  }
)

.during <- function(xmin, xmax, ymin, ymax) {
  xmin > ymin & xmax < ymax
}

# Start ========================================================================
#' @export
#' @rdname relations
#' @aliases starts,TimeIntervals,missing-method
setMethod(
  f = "starts",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .starts,
      labels = labels(x),
      ...
    )
  }
)

.starts <- function(xmin, xmax, ymin, ymax) {
  xmin == ymin & xmax < ymax
}

#' @export
#' @rdname relations
#' @aliases started_by,TimeIntervals,missing-method
setMethod(
  f = "started_by",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .started_by,
      labels = labels(x),
      ...
    )
  }
)

.started_by <- function(xmin, xmax, ymin, ymax) {
  xmin == ymin & xmax > ymax
}

# Equal ========================================================================
#' @export
#' @rdname relations
#' @aliases equals,TimeIntervals,missing-method
setMethod(
  f = "equals",
  signature = c(x = "TimeIntervals"),
  definition = function(x, ...) {
    .relation(
      x = start(x, calendar = NULL),
      y = end(x, calendar = NULL),
      f = .equals,
      labels = labels(x),
      ...
    )
  }
)

.equals <- function(xmin, xmax, ymin, ymax) {
  xmin == ymin & xmax == ymax
}

# Helpers ======================================================================
.relation <- function(x, y, f, labels = NULL, use_names = TRUE) {
  n <- length(x)
  arkhe::assert_function(f)
  arkhe::assert_length(y, n)
  assert_ordered(x, y)

  labels <- labels %||% names(x) %||% names(y)
  if (!isTRUE(use_names)) labels <- seq_along(labels)

  el <- seq_len(n)
  comb <- cbind(
    utils::combn(el, m = 2, simplify = TRUE),
    utils::combn(rev(el), m = 2, simplify = TRUE)
  )
  xmin <- x[comb[1, ]]
  xmax <- y[comb[1, ]]
  ymin <- x[comb[2, ]]
  ymax <- y[comb[2, ]]

  mtx <- matrix(
    data = c(labels[comb[1, ]], labels[comb[2, ]]),
    ncol = 2
  )

  rel <- f(xmin, xmax, ymin, ymax)
  mtx <- mtx[rel, , drop = FALSE]
  mtx <- mtx[order(mtx[, 1], mtx[, 2]), ]
  mtx
}

# HELPERS

## https://michaelchirico.github.io/potools/articles/developers.html
tr_ <- function(...) {
  enc2utf8(gettext(paste0(...), domain = "R-aion"))
}

make_par <- function(params, x, n = 1) {
  p <- params[[x]] %||% graphics::par()[[x]]
  if (length(p) == 1 && n > 1) p <- rep(p, length.out = n)
  p
}

fix_dimnames <- function(x, dim2 = "S", dim3 = "V") {
  if (is.null(dimnames(x)[[2L]])) {
    dimnames(x)[[2L]] <- paste0(dim2, seq_len(dim(x)[[2L]]))
  }
  if (is.null(dimnames(x)[[3L]])) {
    dimnames(x)[[3L]] <- paste0(dim3, seq_len(dim(x)[[3L]]))
  }
  x
}

#' Plotting Dimensions of Character Strings
#'
#' Convert string length in inch to number of (margin) lines.
#' @param x A [`character`] vector of string whose length is to be calculated.
#' @param ... Further parameter to be passed to [graphics::strwidth()]`, such as
#'  `cex`.
#' @return
#'  A [`numeric`] vector (maximum string width in units of margin lines).
#' @note For internal use only.
#' @family graphic tools
#' @keywords internal
#' @noRd
inch2line <- function(x, ...) {
  (max(graphics::strwidth(x, units = "inch", ...)) /
     graphics::par("cin")[2] + graphics::par("mgp")[2]) * graphics::par("cex")
}

# TIME SCALE
#' @include AllGenerics.R
NULL

#' @export
#' @rdname calendar
#' @aliases calendar,character-method
setMethod(
  f = "calendar",
  signature = "character",
  definition = function(object) {
    switch (
      tolower(object),
      bp = BP(),
      b2k = b2k(),
      bc = BC(),
      bce = BCE(),
      ad = AD(),
      ce = CE(),
      julian = J(),
      stop(sprintf(tr_("Unknown calendar: %s"), object), call. = FALSE)
    )
  }
)

#' @export
#' @rdname gregorian
BP <- function(...) {
  .GregorianCalendar(
    label = tr_("BP"),
    name = tr_("Before Present"),
    epoch = 1950,
    direction = -1L
  )
}

#' @export
#' @rdname gregorian
b2k <- function(...) {
  .GregorianCalendar(
    label = tr_("b2k"),
    name = tr_("Before 2000"),
    epoch = 2000,
    direction = -1L
  )
}

#' @export
#' @rdname gregorian
BC <- function(...) {
  .GregorianCalendar(
    label = tr_("BC"),
    name = tr_("Before Christ"),
    direction = -1L
  )
}

#' @export
#' @rdname gregorian
BCE <- function(...) {
  .GregorianCalendar(
    label = tr_("BCE"),
    name = tr_("Before Common Era"),
    direction = -1L
  )
}

#' @export
#' @rdname gregorian
AD <- function(...) {
  .GregorianCalendar(
    label = tr_("AD"),
    name = tr_("Anno Domini")
  )
}

#' @export
#' @rdname gregorian
CE <- function(...) {
  .GregorianCalendar(
    label = tr_("CE"),
    name = tr_("Common Era")
  )
}

#' @export
#' @rdname julian
J <- function(...) {
  .JulianCalendar(
    label = "",
    name = ""
  )
}

# Default calendar =============================================================
the <- new.env(parent = emptyenv())
the$default_calendar <- function(...) calendar("CE")
the$last_calendar <- function(...) return(NULL)

#' @export
#' @rdname get_calendar
get_calendar <- function(which = c("default", "current")) {
  which <- match.arg(which, several.ok = FALSE)
  which_calendar <- switch(
    which,
    default = "default_calendar",
    current = "last_calendar"
  )

  if (!exists(which_calendar, envir = the)) {
    stop(tr_("Unspecified calendar."), call. = FALSE)
  }

  cal <- get(which_calendar, envir = the)
  if (!is.null(cal()) && !is_calendar(cal())) {
    stop(tr_("Invalid calendar."), call. = FALSE)
  }
  return(cal())
}

#' @export
#' @rdname get_calendar
set_calendar <- function(x, which = c("default", "current")) {
  if (missing(x)) x <- "CE"
  which <- match.arg(which, several.ok = FALSE)
  which_calendar <- switch(
    which,
    default = "default_calendar",
    current = "last_calendar"
  )

  cal <- function(...) calendar(x)
  assign(which_calendar, value = cal, envir = the)
  invisible(cal())
}

# Predicates ===================================================================
#' Is an Object a Calendar?
#'
#' Test inheritance relationships between an object and a calendar class.
#' @param object Any \R object.
#' @return
#'  A [`logical`] scalar.
#' @author N. Frerebeau
#' @docType methods
#' @family calendar tools
#' @export
is_calendar <- function(object) {
  methods::is(object, "TimeScale")
}

#' @export
#' @rdname is_calendar
is_gregorian <- function(object) {
  methods::is(object, "GregorianCalendar")
}

#' @export
#' @rdname is_calendar
is_julian <- function(object) {
  methods::is(object, "JulianCalendar")
}

# Mutators =====================================================================
## Getters ---------------------------------------------------------------------
#' @export
#' @rdname calendar_get
#' @aliases calendar_label,TimeScale-method
setMethod(
  f = "calendar_label",
  signature = "TimeScale",
  definition = function(object) object@label
)

#' @export
#' @rdname calendar_get
#' @aliases calendar_name,TimeScale-method
setMethod(
  f = "calendar_name",
  signature = "TimeScale",
  definition = function(object) object@name
)

#' @export
#' @rdname calendar_get
#' @aliases calendar_unit,TimeScale-method
setMethod(
  f = "calendar_unit",
  signature = "TimeScale",
  definition = function(object) {
    if (is_gregorian(object)) return(tr_("Gregorian years"))
    if (is_julian(object)) return(tr_("Julian years"))
    return(tr_("Undefined"))
  }
)

#' @export
#' @rdname calendar_get
#' @aliases calendar_epoch,TimeScale-method
setMethod(
  f = "calendar_epoch",
  signature = "TimeScale",
  definition = function(object) object@epoch
)

#' @export
#' @rdname calendar_get
#' @aliases calendar_fixed,TimeScale-method
setMethod(
  f = "calendar_fixed",
  signature = "TimeScale",
  definition = function(object) object@fixed
)

#' @export
#' @rdname calendar_get
#' @aliases calendar_direction,TimeScale-method
setMethod(
  f = "calendar_direction",
  signature = "TimeScale",
  definition = function(object) sign(object@direction)
)

#' @export
#' @rdname calendar_get
#' @aliases calendar_direction,NULL-method
setMethod(
  f = "calendar_direction",
  signature = "NULL",
  definition = function(object) 1L
)

#' @export
#' @rdname calendar_get
#' @aliases calendar_year,TimeScale-method
setMethod(
  f = "calendar_year",
  signature = "TimeScale",
  definition = function(object) object@year
)

# AXIS

# Pretty =======================================================================
#' @export
#' @method pretty RataDie
pretty.RataDie <- function(x, calendar = get_calendar(), ...) {
  if (is.null(calendar)) return(pretty(as.numeric(x), ...))

  x <- as_year(x, calendar = calendar, decimal = FALSE)
  x <- pretty(x, ...)
  if (methods::is(calendar, "JulianCalendar")) x[x == 0] <- 1
  fixed(year = x, calendar = calendar)
}

#' @export
#' @rdname pretty
setMethod("pretty", "RataDie", pretty.RataDie)

# Axis =========================================================================
#' @export
#' @rdname year_axis
year_axis <- function(side, at = NULL, format = c("a", "ka", "Ma", "Ga"),
                      labels = TRUE, calendar = get_calendar("current"),
                      current_calendar = get_calendar("current"),
                      ...) {
  no_at <- missing(at) || is.null(at) || !is.numeric(at)
  if (no_at) at <- graphics::axTicks(side = side)

  if (!is.logical(labels)) {
    labels <- labels[keep]
  } else if (isTRUE(labels)) {
    ## If last_calendar is NULL, then the last plot was expressed in rata die
    if (is.null(current_calendar)) {
      at <- as_fixed(at)
    } else {
      if (methods::is(calendar, "JulianCalendar")) at[at == 0] <- 1
      at <- fixed(at, calendar = current_calendar)
    }
    if (!is.null(calendar)) {
      at <- pretty(at, calendar = calendar)
      labels <- format(at, prefix = format, label = FALSE, calendar = calendar)
      if (!is.null(current_calendar)) at <- as_year(at, calendar = current_calendar)
    }
  } else if (isFALSE(labels)) {
    labels <- rep("", length(at))
  }

  graphics::axis(side, at = as.numeric(at), labels = labels, ...)
}

# TIME
#' @include AllGenerics.R
NULL

#' @export
#' @method start TimeSeries
start.TimeSeries <- function(x, calendar = NULL, ...) {
  z <- min(x@.Time)
  if (is.null(calendar)) return(z)
  as_year(z, calendar = calendar, decimal = TRUE)
}

#' @export
#' @rdname start
#' @aliases start,TimeSeries-method
setMethod("start", "TimeSeries", start.TimeSeries)

#' @export
#' @method start TimeIntervals
start.TimeIntervals <- function(x, calendar = NULL, ...) {
  z <- x@.Start
  if (is.null(calendar)) return(z)
  as_year(z, calendar = calendar, decimal = TRUE)
}

#' @export
#' @rdname start
#' @aliases start,TimeIntervals-method
setMethod("start", "TimeIntervals", start.TimeIntervals)

#' @export
#' @method end TimeSeries
end.TimeSeries <- function(x, calendar = NULL, ...) {
  z <- max(x@.Time)
  if (is.null(calendar)) return(z)
  as_year(z, calendar = calendar, decimal = TRUE)
}

#' @export
#' @rdname start
#' @aliases end,TimeSeries-method
setMethod("end", "TimeSeries", end.TimeSeries)

#' @export
#' @method end TimeIntervals
end.TimeIntervals <- function(x, calendar = NULL, ...) {
  z <- x@.End
  if (is.null(calendar)) return(z)
  as_year(z, calendar = calendar, decimal = TRUE)
}

#' @export
#' @rdname start
#' @aliases end,TimeIntervals-method
setMethod("end", "TimeIntervals", end.TimeIntervals)

#' @export
#' @method time TimeSeries
time.TimeSeries <- function(x, calendar = NULL, ...) {
  z <- x@.Time
  if (is.null(calendar)) return(z)
  as_year(z, calendar = calendar, decimal = TRUE)
}

#' @export
#' @rdname time
#' @aliases time,TimeSeries-method
setMethod("time", "TimeSeries", time.TimeSeries)

#' @export
#' @method frequency TimeSeries
frequency.TimeSeries <- function(x, ...) {
  mean(abs(1 / diff(time(x))))
}

#' @export
#' @rdname time
#' @aliases frequency,TimeSeries-method
setMethod("frequency", "TimeSeries", frequency.TimeSeries)

# TIME INTERVALS
#' @include AllGenerics.R
NULL

#' @export
#' @rdname intervals
#' @aliases intervals,RataDie,RataDie,missing-method
setMethod(
  f = "intervals",
  signature = c(start = "RataDie", end = "RataDie", calendar = "missing"),
  definition = function(start, end, names = NULL) {
    n <- length(start)
    arkhe::assert_length(end, n)

    ## Set the names
    if (is.null(names)) {
      names <- paste0("I", seq_len(n))
    } else {
      names <- as.character(names)
    }
    arkhe::assert_length(names, n)

    .TimeIntervals(.Id = names, .Start = start, .End = end)
  }
)

#' @export
#' @rdname intervals
#' @aliases intervals,numeric,numeric,TimeScale-method
setMethod(
  f = "intervals",
  signature = c(start = "numeric", end = "numeric", calendar = "TimeScale"),
  definition = function(start, end, calendar, scale = 1, names = NULL) {
    ## Start
    if (methods::is(start, "RataDie")) {
      msg <- "%s is already expressed in rata die: %s is ignored."
      warning(sprintf(msg, sQuote("start"), sQuote("calendar")), call. = FALSE)
    } else {
      start <- fixed(start, calendar = calendar, scale = scale)
    }

    ## End
    if (methods::is(end, "RataDie")) {
      msg <- tr_("%s is already expressed in rata die: %s is ignored.")
      warning(sprintf(msg, sQuote("end"), sQuote("calendar")), call. = FALSE)
    } else {
      end <- fixed(end, calendar = calendar, scale = scale)
    }

    names <- names %||% names(start) %||% names(end)
    methods::callGeneric(start = start, end = end, names = names)
  }
)

# JULINA CALENDAR
#' @include AllGenerics.R
NULL

# Fixed from Julian ============================================================
#' @export
#' @rdname fixed
#' @aliases fixed,numeric,missing,missing,JulianCalendar-method
setMethod(
  f = "fixed",
  signature = c(year = "numeric", month = "missing", day = "missing", calendar = "JulianCalendar"),
  definition = function(year, calendar, scale = 1) {
    ## Rescale to years (if not already)
    year <- year * scale

    rd <- fixed(year, 01, 01, calendar = calendar)

    is_leap <- which(is_julian_leap_year(year))
    rd[is_leap] <- ceiling(rd[is_leap]) # WHY ???
    rd
  }
)

#' @export
#' @rdname fixed
#' @aliases fixed,numeric,numeric,numeric,JulianCalendar-method
setMethod(
  f = "fixed",
  signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "JulianCalendar"),
  definition = function(year, month, day, calendar) {
    ## Validation
    if (any(year == 0)) {
      stop(tr_("There is no year zero in the Julian calendar."), call. = FALSE)
    }

    ## Correct for 28- or 29-day Feb
    correction <- rep(-2, length(year))
    correction[which(is_julian_leap_year(year))] <- -1
    correction[month <= 2] <- 0

    ## There is no year 0 on the Julian calendar
    year[year < 0] <- year[year < 0] + 1

    rd <- calendar_fixed(calendar) - 1 + # Days before start of calendar
      365 * (year - 1) +                 # Ordinary days since epoch
      (year - 1) %/% 4 +                 # Leap days since epoch
      (367 * month - 362) %/% 12 +       # Days in prior months this year assuming 30-day Feb
      correction +                       # Correct for 28- or 29-day Feb
      day                                # Days so far this month.

    ## Fix infinite values
    rd[is.infinite(year)] <- year[is.infinite(year)]

    .RataDie(rd)
  }
)

# Julian from fixed ============================================================
#' @export
#' @rdname as_year
#' @aliases as_year,numeric,JulianCalendar-method
setMethod(
  f = "as_year",
  signature = c(object = "numeric", calendar = "JulianCalendar"),
  definition = function(object, calendar, decimal = FALSE, ...) {
    d0 <- object - calendar_fixed(calendar)
    year <- (4 * d0 + 1464) %/% 1461

    ## There is no year 0 on the Julian calendar
    year[year <= 0] <- year[year <= 0] - 1

    if (isTRUE(decimal)) {
      ## Year length in days
      start <- fixed(year, 01, 01, calendar = calendar)
      end <- fixed(year, 12, 31, calendar = calendar)
      total <- end - start + 1

      ## Elapsed time
      sofar <- object - start

      year <- year + sofar / total
    }

    ## Fix infinite values
    year[is.infinite(object)] <- object[is.infinite(object)]

    unclass(year)
  }
)

#' @export
#' @rdname as_date
#' @aliases as_date,numeric,JulianCalendar-method
setMethod(
  f = "as_date",
  signature = c(object = "numeric", calendar = "JulianCalendar"),
  definition = function(object, calendar) {
    year <- as_year(object, calendar = calendar, decimal = FALSE)
    prior_days <- object - fixed(year, 01, 01, calendar = calendar)

    correction <- rep(2, length(object))
    correction[object < fixed(year, 03, 01, calendar = calendar)] <- 0
    correction[is_julian_leap_year(year)] <- 1

    month <- (12 * (prior_days + correction) + 373) %/% 367
    day <- object - fixed(year, month, 01, calendar = calendar) + 1

    data.frame(
      year = unclass(year),
      month = unclass(month),
      day = unclass(day)
    )
  }
)

# Era ==========================================================================
#' @export
#' @rdname fixed_julian
fixed_from_julian <- function(year, month, day) {
  if (missing(month) || missing(day)) fixed(year, calendar = J())
  else fixed(year, month, day, calendar = J())
}

#' @export
#' @rdname fixed_julian
fixed_to_julian <- function(object) {
  as_year(object, calendar = J())
}

# GENERIC METHODS
#' @include AllClasses.R
NULL

# Tools ========================================================================
## Mutators --------------------------------------------------------------------
# Get or Set Parts of an Object
#
# Getters and setters to extract or replace parts of an object.
# @param x An object from which to get or set element(s).
# @param value A possible value for the element(s) of `x`.
# @return
#  An object of the same sort as `x` with the new values assigned.
# @example inst/examples/ex-mutator.R
# @author N. Frerebeau
# @docType methods
# @family mutators
# @name mutators
# @rdname mutators
# @aliases get set
# NULL

#' Labels
#'
#' Find a suitable set of labels from an object.
#' @param object An \R object.
#' @param ... Currently not used.
#' @return
#'  A [`character`] vector.
#' @author N. Frerebeau
#' @docType methods
#' @family mutators
#' @name labels
#' @rdname labels
NULL

#' Names
#'
#' Get or set the names of an object.
#' @param x An \R object.
#' @param value	A [`character`] vector of up to the same length as `x`, or
#'  `NULL`.
#' @return
#'  The updated object.
#' @author N. Frerebeau
#' @docType methods
#' @family mutators
#' @name names
#' @rdname names
NULL

#' Length
#'
#' Get the length of an object.
#' @param x An \R object.
#' @return
#'  A length-one [`integer`] vector.
#' @author N. Frerebeau
#' @docType methods
#' @family mutators
#' @name length
#' @rdname length
NULL

## Subset ----------------------------------------------------------------------
#' Extract or Replace Parts of an Object
#'
#' Operators acting on objects to extract or replace parts.
#' @param x An object from which to extract element(s) or in which to replace
#'  element(s).
#' @param i,j,k Indices specifying elements to extract or replace.
#' @param drop A [`logical`] scalar: should the result be coerced to
#'  the lowest possible dimension? This only works for extracting elements,
#'  not for the replacement.
# @param value A possible value for the element(s) of `x`.
# @param ... Currently not used.
#' @return
#'  A subsetted object.
# @example inst/examples/ex-subset.R
#' @author N. Frerebeau
#' @docType methods
#' @family subsetting methods
#' @name subset
#' @rdname subset
NULL

## Flip ------------------------------------------------------------------------
#' Transposition
#'
#' Transposes a time series object by permuting its dimensions and resizing it.
#' @param x A \eqn{n \times m \times p} [`TimeSeries-class`] object.
#' @param ... Currently not used.
#' @return
#'  A permuted (\eqn{n \times p \times m}) [`TimeSeries-class`] object.
#' @example inst/examples/ex-flip.R
#' @author N. Frerebeau
#' @docType methods
#' @family mutators
setGeneric(
  name = "flip",
  def = function(x, ...) standardGeneric("flip"),
  valueClass = "TimeSeries"
)

## Coerce ----------------------------------------------------------------------
#' Coerce to a Data Frame
#'
#' @param x A [`TimeSeries-class`] or a [`TimeIntervals-class`] object.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]). If `NULL` (the default), *rata die* are returned.
#' @param ... Further parameters to be passed to [data.frame()].
#' @return
#'  A [`data.frame`].
#' @example inst/examples/ex-series.R
#' @author N. Frerebeau
#' @docType methods
#' @family coercion methods
#' @name as.data.frame
#' @rdname as.data.frame
NULL

#' Coerce to an Array
#'
#' @param x A [`TimeSeries-class`].
#' @param ... Currently not used.
#' @return
#'  An [`array`].
#' @note
#'  June 2026: aperm.default() now copy attributes, this change how apply()
#'  works on classed objects. The simplest "fix" is to add an aperm() S3 method
#'  for the class which drops attributes as aperm.default() previously did.
#'  Alternatively, one could also consider providing as.matrix()/as.array()
#'  methods which change to standard matrix/array.
#' @example inst/examples/ex-series.R
#' @author N. Frerebeau
#' @docType methods
# @family coercion methods
#' @keywords internal
#' @name as.array
#' @rdname as.array
NULL

# Calendars ====================================================================
#' Calendar
#'
#' @param object A [`character`] string specifying the abbreviated label of
#'  the time scale (see details).
#' @details
#'  The following time scales are available:
#'
#'  \tabular{lll}{
#'   **label**   \tab **era**            \tab **calendar** \cr
#'   `BP`        \tab Before Present     \tab Gregorian    \cr
#'   `BC`        \tab Before Christ      \tab Gregorian    \cr
#'   `BCE`       \tab Before Common Era  \tab Gregorian    \cr
#'   `AD`        \tab Anno Domini        \tab Gregorian    \cr
#'   `CE`        \tab Common Era         \tab Gregorian    \cr
#'   `b2k`       \tab Years before 2000  \tab Gregorian    \cr
#'   `julian`    \tab                    \tab Julian       \cr
#'  }
#' @return
#'  A [`TimeScale-class`] object.
#' @note
#'  Inspired by [era::era()] by Joe Roe.
#' @example inst/examples/ex-calendar.R
#' @author N. Frerebeau
#' @docType methods
#' @family calendar tools
#' @aliases calendar-method
setGeneric(
  name = "calendar",
  def = function(object) standardGeneric("calendar"),
  valueClass = "TimeScale"
)

#' Gregorian Calendar
#'
#' @param ... Currently not used.
#' @return
#'  A [`GregorianCalendar-class`] object.
#' @example inst/examples/ex-calendar.R
#' @seealso [calendar()]
#' @author N. Frerebeau
#' @docType methods
#' @family calendar tools
#' @name gregorian
#' @rdname gregorian
NULL

#' Julian Calendar
#'
#' @param ... Currently not used.
#' @return
#'  A [`JulianCalendar-class`] object.
#' @example inst/examples/ex-calendar.R
#' @seealso [calendar()]
#' @author N. Frerebeau
#' @docType methods
#' @family calendar tools
#' @name julian
#' @rdname julian
NULL

#' Get or Set the Default Calendar
#'
#' @param x A [`character`] string specifying the abbreviated label of
#'  the time scale (see [calendar()]) or an object from which to extract the
#'  time scale.
#' @param which A [`character`] string specifying the calendar to be set.
#'  It must be one of "`default`" or "`current`". Note that "`current`" is
#'  automatically set by [plot()] or [image()] and should not be changed
#'  manually.
#' @return
#'  A [`TimeScale-class`] object.
#' @example inst/examples/ex-calendar.R
#' @author N. Frerebeau
#' @docType methods
#' @family calendar tools
#' @name get_calendar
#' @rdname get_calendar
NULL

#' Calendar Parameters
#'
#' @param object A [`TimeScale-class`] object.
#' @return
#'  * `calendar_label()` returns a [`character`] string giving the
#'     abbreviated label of the time scale.
#'  * `calendar_name()` returns a [`character`] string giving the name of
#'     the time scale.
#'  * `calendar_unit()` returns a [`character`] string giving the unit of
#'     the calendar.
#'  * `calendar_fixed()` returns a length-one [`numeric`] vector giving the
#'     reference date of the calendar (in *rata die*).
#'  * `calendar_epoch()` returns a length-one [`numeric`] vector giving the
#'     epoch year from which years are counted (starting date of the calendar,
#'     in years).
#'  * `calendar_direction()` returns a length-one [`integer`] vector specifying
#'     if years are counted backwards (\eqn{-1}) or forwards (\eqn{1}) from
#'     `epoch`. Only the [sign][sign()] of `calendar_direction()` is relevant.
#'  * `calendar_year()` returns a length-one [`numeric`] vector giving the
#'     average length of the year in solar days.
#' @example inst/examples/ex-calendar.R
#' @author N. Frerebeau
#' @docType methods
#' @family calendar tools
#' @name calendar_get
#' @rdname calendar_get
NULL

#' @rdname calendar_get
#' @aliases calendar_label-method
setGeneric(
  name = "calendar_label",
  def = function(object) standardGeneric("calendar_label")
)

#' @rdname calendar_get
#' @aliases calendar_name-method
setGeneric(
  name = "calendar_name",
  def = function(object) standardGeneric("calendar_name")
)

#' @rdname calendar_get
#' @aliases calendar_unit-method
setGeneric(
  name = "calendar_unit",
  def = function(object) standardGeneric("calendar_unit")
)

#' @rdname calendar_get
#' @aliases calendar_epoch-method
setGeneric(
  name = "calendar_epoch",
  def = function(object) standardGeneric("calendar_epoch")
)

#' @rdname calendar_get
#' @aliases calendar_fixed-method
setGeneric(
  name = "calendar_fixed",
  def = function(object) standardGeneric("calendar_fixed")
)

#' @rdname calendar_get
#' @aliases calendar_direction-method
setGeneric(
  name = "calendar_direction",
  def = function(object) standardGeneric("calendar_direction")
)

#' @rdname calendar_get
#' @aliases calendar_year-method
setGeneric(
  name = "calendar_year",
  def = function(object) standardGeneric("calendar_year")
)

# @rdname calendar_get
# @aliases calendar_fixed-method
# setGeneric(
#   name = "calendar_fixed",
#   def = function(object) standardGeneric("calendar_fixed")
# )

# @rdname calendar_get
# @aliases calendar_year-method
# setGeneric(
#   name = "calendar_year",
#   def = function(object) standardGeneric("calendar_year")
# )

#' Calendar Converter
#'
#' Interconverts dates in a variety of calendars.
#' @param from A [`TimeScale-class`] object describing the source calendar.
#' @param to A [`TimeScale-class`] object describing the target calendar.
#' @param ... Currently not used.
#' @return
#'  A [`function`] that when called with a single numeric argument (factional
#'  years) converts years from one calendar to another.
#' @example inst/examples/ex-convert.R
#' @author N. Frerebeau
#' @docType methods
#' @family calendar tools
#' @aliases convert-method
setGeneric(
  name = "convert",
  def = function(from, to, ...) standardGeneric("convert")
)

# Fixed Dates ==================================================================
#' *Rata Die* (Fixed Date)
#'
#' @param year A [`numeric`] vector of years. If `month` and `day` are missing,
#'  decimal years are expected.
#' @param month A [`numeric`] vector of months.
#' @param day A [`numeric`] vector of days.
#' @param calendar A [`TimeScale-class`] object specifying the calendar of
#'  `year`, `month` and `day` (see [calendar()]).
#' @param scale A length-one [`integer`] vector specifying the number of years
#'  represented by one unit. It should be a power of 10 (i.e. 1000 means ka).
#' @param ... Currently not used.
#' @details
#'  *Rata die* are represented as the number of days since 01-01-01 (Gregorian),
#'  with negative values for earlier dates.
#' @return
#'  A [`RataDie-class`] object.
#' @example inst/examples/ex-fixed.R
#' @references
#'  Reingold, E. M. and Dershowitz, N. (2018). *Calendrical Calculations:
#'  The Ultimate Edition*. Cambridge University Press.
#'  \doi{10.1017/9781107415058}.
#' @author N. Frerebeau
#' @docType methods
#' @family fixed date tools
#' @aliases fixed-method
setGeneric(
  name = "fixed",
  def = function(year, month, day, calendar, ...) standardGeneric("fixed"),
  valueClass = "RataDie"
)

#' Coerce to *Rata Die*
#'
#' @param from A [`numeric`] vector of *rata die*.
#' @return
#'  A [`RataDie-class`] object.
#' @example inst/examples/ex-fixed.R
#' @references
#'  Reingold, E. M. and Dershowitz, N. (2018). *Calendrical Calculations:
#'  The Ultimate Edition*. Cambridge University Press.
#'  \doi{10.1017/9781107415058}.
#' @author N. Frerebeau
#' @docType methods
#' @family fixed date tools
#' @aliases as_fixed-method
setGeneric(
  name = "as_fixed",
  def = function(from) standardGeneric("as_fixed"),
  valueClass = "RataDie"
)

#' Year Conversion from *Rata Die*
#'
#' @param object A [`RataDie-class`] object (see [fixed()]).
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]).
#' @param decimal A [`logical`] scalar: should decimal years be returned?
#'  If `FALSE`, the decimal part is dropped.
#' @param ... Currently not used.
#' @return
#'  A [`numeric`] vector of (decimal) years.
#' @example inst/examples/ex-fixed.R
#' @references
#'  Reingold, E. M. and Dershowitz, N. (2018). *Calendrical Calculations:
#'  The Ultimate Edition*. Cambridge University Press.
#'  \doi{10.1017/9781107415058}.
#' @author N. Frerebeau
#' @docType methods
#' @family fixed date tools
#' @aliases as_year-method
setGeneric(
  name = "as_year",
  def = function(object, calendar, ...) standardGeneric("as_year")
)

#' *Rata Die* Conversion to and from Gregorian Years
#'
#' Convenient functions for conversion from and to *rata die* for a given
#' Gregorian era.
#' @inheritParams fixed
#' @inheritParams as_year
#' @return
#'  * `fixed_from_*()` returns a [`RataDie-class`] object.
#'  * `fixed_to_*()` returns a [`numeric`] vector of Gregorian years.
#' @example inst/examples/ex-fixed.R
#' @details
#'  The astronomical notation is used for Gregorian years (there *is* a year 0).
#' @references
#'  Reingold, E. M. and Dershowitz, N. (2018). *Calendrical Calculations:
#'  The Ultimate Edition*. Cambridge University Press.
#'  \doi{10.1017/9781107415058}.
#' @author N. Frerebeau
#' @docType methods
#' @family fixed date tools
#' @name fixed_gregorian
#' @rdname fixed_gregorian
NULL

#' *Rata Die* Conversion to and from Julian Years
#'
#' Convenient functions for conversion from and to *rata die*.
#' @inheritParams fixed
#' @inheritParams as_year
#' @return
#'  * `fixed_from_julian()` returns a [`RataDie-class`] object.
#'  * `fixed_to_julian()` returns a [`numeric`] vector of Julian years.
#' @example inst/examples/ex-fixed.R
#' @references
#'  Reingold, E. M. and Dershowitz, N. (2018). *Calendrical Calculations:
#'  The Ultimate Edition*. Cambridge University Press.
#'  \doi{10.1017/9781107415058}.
#' @author N. Frerebeau
#' @docType methods
#' @family fixed date tools
#' @name fixed_julian
#' @rdname fixed_julian
NULL

#' Date Conversion from *Rata Die*
#'
#' @param object A [`RataDie-class`] object (see [fixed()]).
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]).
#' @return
#'  A [`numeric`] vector of (decimal) years.
#' @example inst/examples/ex-fixed.R
#' @references
#'  Reingold, E. M. and Dershowitz, N. (2018). *Calendrical Calculations:
#'  The Ultimate Edition*. Cambridge University Press.
#'  \doi{10.1017/9781107415058}.
#' @author N. Frerebeau
#' @docType methods
#' @family fixed date tools
#' @aliases as_date-method
setGeneric(
  name = "as_date",
  def = function(object, calendar) standardGeneric("as_date"),
  valueClass = "data.frame"
)

#' Converts a Date to a Decimal of its Year
#'
#' @param year A [`numeric`] vector of years. If `month` and `day` are missing,
#'  decimal years are expected.
#' @param month A [`numeric`] vector of months.
#' @param day A [`numeric`] vector of days.
#' @param calendar A [`TimeScale-class`] object specifying the calendar of
#'  `year`, `month` and `day` (see [calendar()]).
#' @return
#'  A [`numeric`] vector of (ecimal years.
#' @example inst/examples/ex-fixed.R
#' @author N. Frerebeau
#' @docType methods
#' @family fixed date tools
#' @aliases as_decimal-method
setGeneric(
  name = "as_decimal",
  def = function(year, month, day, calendar) standardGeneric("as_decimal")
)

#' Date Conversion to Character
#'
#' @param x A [`RataDie-class`] object.
#' @param prefix A [`character`] string specifying the prefix.
#'  It should be one of "`a`", "`ka`", "`Ma`" or "`Ga`".
#'  If `TRUE`, a good guess for an appropriate format is made.
#' @param label A [`logical`] scalar: should the label of the calendar be
#'  displayed?
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]).
#' @param ... Currently not used.
#' @return
#'  A [`character`] vector representing the date.
#' @example inst/examples/ex-fixed.R
#' @author N. Frerebeau
#' @docType methods
#' @family fixed date tools
#' @name format
#' @rdname format
NULL

#' Pretty Breakpoints
#'
#' @param x A [`RataDie-class`] object.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]).
#' @param ... Further parameters to be passed to [base::pretty()].
#' @details
#'  `pretty()` computes a vector of increasing numbers which are "pretty" in
#'  decimal notation of `calendar`. Pretty breakpoints are then converted to
#'  *rata die*.
#' @return
#'  A [`RataDie-class`] object.
#' @docType methods
#' @family fixed date tools
#' @name pretty
#' @rdname pretty
NULL

#' Arithmetic Operators
#'
#' Operators performing arithmetic operations.
#' @param e1,e2 A [`RataDie-class`] object or a [`numeric`] vector.
#' @details
#'  *Rata die* will be converted to a plain `numeric` vector if a computation no
#'  longer makes sense in temporal terms.
#' @return
#'  A [`logical`] vector.
#' @example inst/examples/ex-arith.R
#' @author N. Frerebeau
#' @docType methods
#' @family fixed date tools
#' @name arithmetic
#' @rdname arithmetic
NULL

# Time Series ==================================================================
#' Create Time Series
#'
#' @param object A [`numeric`] `vector`, `matrix` or `array` of the observed
#'  time-series values. A [`data.frame`] will be coerced to a `numeric` `matrix`
#'  via [data.matrix()].
#' @param time A [`numeric`] vector of (decimal) years or a [`RataDie-class`]
#'  object (see [fixed()]).
#' @param calendar A [`TimeScale-class`] object specifying the calendar of
#'  `time` (see [calendar()]). If missing, `time` must be a [`RataDie-class`]
#'  object.
#' @param scale A length-one [`numeric`] vector specifying the number of years
#'  represented by one unit. It should be a power of 10 (i.e. 1000 means ka).
#' @param names A [`character`] string specifying the names of the time
#'  series.
#' @param ... Currently not used.
#' @details
#'  Data will be sorted in chronological order.
#' @return
#'  A [`TimeSeries-class`] object.
#' @example inst/examples/ex-series.R
#' @author N. Frerebeau
#' @docType methods
#' @family time series
#' @aliases series-method
setGeneric(
  name = "series",
  def = function(object, time, calendar, ...) standardGeneric("series"),
  valueClass = "TimeSeries"
)

# Time Intervals ===============================================================
#' Create Time Intervals
#'
#' An Interval is elapsed time in seconds between two specific years.
#' @param start A [`numeric`] vector of (decimal) years or a [`RataDie-class`]
#'  object (see [fixed()]) giving the beginning of the time intervals.
#' @param end A [`numeric`] vector of (decimal) years or a [`RataDie-class`]
#'  object (see [fixed()]) giving the end of the time intervals.
#' @param calendar A [`TimeScale-class`] object specifying the calendar of
#'  `time` (see [calendar()]). If missing, `time` must be a [`RataDie-class`]
#'  object.
#' @param scale A length-one [`numeric`] vector specifying the number of years
#'  represented by one unit. It should be a power of 10 (i.e. 1000 means ka).
#' @param names A [`character`] string specifying the names of the time
#'  series.
#' @param ... Currently not used.
#' @return
#'  A [`TimeIntervals-class`] object.
#' @example inst/examples/ex-intervals.R
#' @author N. Frerebeau
#' @docType methods
#' @family time intervals
#' @aliases intervals-method
setGeneric(
  name = "intervals",
  def = function(start, end, calendar, ...) standardGeneric("intervals"),
  valueClass = "TimeIntervals"
)

# Tools ========================================================================
#' Terminal Times
#'
#' Get the times the first and last observations were taken.
#' @param x A [`TimeSeries-class`] object.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]). If `NULL` (the default), *rata die* are returned.
#' @param ... Currently not used.
#' @return
#'  A [`numeric`] vector of decimal years (if `calendar` is not `NULL`).
#' @example inst/examples/ex-series.R
#' @author N. Frerebeau
#' @docType methods
#' @family tools
#' @aliases start-method end-method
#' @name start
#' @rdname start
NULL

#' Sampling Times
#'
#' Get the sampling times:
#' * `time()` creates the vector of times at which a time series was sampled.
#' * `frequency()` returns the mean number of samples per unit time.
#' @param x A [`TimeSeries-class`] object.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]). If `NULL` (the default), *rata die* are returned.
#' @param ... Currently not used.
#' @return
#'  A [`numeric`] vector of decimal years (if `calendar` is not `NULL`).
#' @example inst/examples/ex-series.R
#' @author N. Frerebeau
#' @docType methods
#' @family tools
#' @aliases time-method frequency-method
#' @name time
#' @rdname time
NULL

#' Time Windows
#'
#' Extracts the subset of the object `x` observed between the times `start` and
#' `end` (expressed in *rata die*).
#' @param x A [`TimeSeries-class`] object.
#' @param start A length-one [`numeric`] vector specifying the start time of the
#'  period of interest.
#' @param end A length-one [`numeric`] vector specifying the end time of the
#'  period of interest.
#' @param ... Currently not used.
#' @return
#'  A [`TimeSeries-class`] object.
#' @example inst/examples/ex-window.R
#' @author N. Frerebeau
#' @docType methods
#' @family tools
#' @aliases window-method
#' @name window
#' @rdname window
NULL

#' Duration
#'
#' Get the duration of time series or intervals.
#' @param x A [`TimeSeries-class`] or a [`TimeIntervals-class`] object.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]). If `NULL` (the default), *rata die* are returned.
#' @param ... Currently not used.
#' @return
#'  A [`numeric`] vector of years.
#' @example inst/examples/ex-duration.R
#' @author N. Frerebeau
#' @docType methods
#' @family tools
#' @aliases span-method
setGeneric(
  name = "span",
  def = function(x, ...) standardGeneric("span")
)

# Plot =========================================================================
#' Plot Time Series and Time Intervals
#'
#' @param x A [`TimeSeries-class`] or a [`TimeIntervals-class`] object.
#' @param facet A [`character`] string specifying whether the series should be
#'  plotted separately (with a common time axis) or on a single plot?
#'  It must be one of "`multiple`" or "`single`". Any unambiguous substring can
#'  be given.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]).
#' @param groups A [`character`] vector specifying the group each interval
#'  belongs to.
#' @param sort A [`logical`] scalar: should the data be sorted in chronological
#'  order?
#' @param decreasing A [`logical`] scalar: should the sort order be decreasing?
#'  Only used if `sort` is `TRUE`.
#' @param panel A [`function`] in the form `function(x, y, ...)`
#'  which gives the action to be carried out in each panel of the display.
#'  The default is [graphics::lines()].
#' @param flip A [`logical`] scalar: should the y-axis (ticks and numbering) be
#'  flipped from side 2 (left) to 4 (right) from series to series when `facet`
#'  is "`multiple`"?
#' @param ncol An [`integer`] specifying the number of columns to use when
#'  `facet` is "`multiple`". Defaults to 1 for up to 4 series, otherwise to 2.
#' @param xlab,ylab A [`character`] vector giving the x and y axis labels.
#' @param main A [`character`] string giving a main title for the plot.
#' @param sub A [`character`] string giving a subtitle for the plot.
#' @param ann A [`logical`] scalar: should the default annotation (title and x
#'  and y axis labels) appear on the plot?
#' @param axes A [`logical`] scalar: should axes be drawn on the plot?
#' @param frame.plot A [`logical`] scalar: should a box be drawn around the
#'  plot?
#' @param panel.first An `expression` to be evaluated after the plot axes are
#'  set up but before any plotting takes place. This can be useful for drawing
#'  background grids.
#' @param panel.last An `expression` to be evaluated after plotting has taken
#'  place but before the axes, title and box are added.
#' @param ... Further parameters to be passed to `panel`
#'  (e.g. [graphical parameters][graphics::par]).
#' @return
#'  `plot()` is called for its side-effects: it results in a graphic
#'  being displayed. Invisibly returns `x`.
#' @example inst/examples/ex-plot.R
#' @seealso [graphics::plot()]
#' @author N. Frerebeau
#' @docType methods
#' @family plotting tools
#' @name plot
#' @rdname plot
NULL

#' Heat Map
#'
#' @param x A [`TimeSeries-class`] object.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]).
#' @param k An [`integer`] specifying the slice of `x` along the third
#'  dimension to be plotted.
#' @param ... Further parameters to be passed to [graphics::image()].
#' @return
#'  `image()` is called for its side-effects: it results in a graphic
#'  being displayed. Invisibly returns `x`.
#' @example inst/examples/ex-image.R
#' @seealso [graphics::image()]
#' @author N. Frerebeau
#' @docType methods
#' @family plotting tools
#' @name image
#' @rdname image
NULL

#' Time Series Plotting Functions
#'
#' @param side An [`integer`] specifying which side of the plot the axis is to
#'  be drawn on. The axis is placed as follows: 1=below, 2=left, 3=above and
#'  4=right.
#' @param at A [`numeric`] vector giving the points at which tick-marks are to
#'  be drawn. If `NULL`, tickmark locations are computed.
#' @param format A [`character`] string specifying the prefix.
#'  It should be one of "`a`", "`ka`", "`Ma`" or "`Ga`".
#'  If `TRUE`, a good guess for an appropriate format is made.
#' @param labels A [`logical`] scalar specifying whether annotations are to be
#'  made at the tickmarks, or a vector of [`character`] strings to be placed at
#'  the tickpoints.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]).
#' @param current_calendar A [`TimeScale-class`] object specifying the calendar
#'  used by the last call to [plot()].
#' @param ... Further parameters to be passed to [graphics::axis()].
#'  (e.g. [graphical parameters][graphics::par]).
#' @return
#'  `year_axis()` is called it for its side-effects.
#' @example inst/examples/ex-axis.R
#' @author N. Frerebeau
#' @docType methods
#' @family plotting tools
#' @name year_axis
#' @rdname year_axis
NULL

# Chronological Reasoning ======================================================
#' Create a Graph
#'
#' Creates an interval or a stratigraphic graph.
#' @param object A [`TimeIntervals-class`] object or a two-columns `character`
#'  [`matrix`] of edges (i.e. where each row specifies one relation element).
#' @param type A [`character`] string specifying the type of the graph to be
#'  computed. It must be one of "`interval`" (the default) or "`stratigraphy`"
#'  (see details). Any unambiguous substring can be given.
#' @param direction A [`character`] string specifying the direction of the
#'  relations in `x`. It must be one of "`above`" (the default) or "`below`"
#'  (see details). Any unambiguous substring can be given.
#'  Only relevant if `type` is "`stratigraphy`".
#' @param verbose A [`logical`] scalar: should \R report extra information
#'  on progress?
#' @param ... Currently not used.
#' @details
#'  \describe{
#'   \item{`interval`}{An interval graph is the graph showing intersecting
#'   intervals on a line. As time is linear and not circular, an interval graph
#'   contains no cycles with more than three edges and no shortcuts (it must be
#'   a chordal graph).}
#'   \item{`stratigraphy`}{A stratigraphic graph represents the directed
#'   relationships between temporal units (archaeological deposits), from the
#'   most recent to the oldest (Harris 1997). It can be formally defined as a
#'   directed acyclic graph (DAG), in which each vertex represents a layer and
#'   the edges represent stratigraphic relations.}
#'  }
#' @return
#'  An \pkg{igraph} graph object.
#' @note
#'  Experimental.
#'
#'  The \pkg{igraph} and \pkg{relations} packages need to be installed on your
#'  machine.
#' @references
#'  Harris, Edward C., 1997. *Principles of Archaeological Stratigraphy*.
#'  Seconde edition. Academic Press.
#' @example inst/examples/ex-graph.R
#' @author N. Frerebeau
#' @docType methods
#' @family graph tools
#' @aliases graph_create-method
setGeneric(
  name = "graph_create",
  def = function(object, ...) standardGeneric("graph_create")
)

#' Prune a Graph
#'
#' Removes redundant relations from a graph.
#' @param object An \pkg{igraph} object (typically returned by
#'  [graph_create()]).
#' @param reduce A [`logical`] scalar: should transitive reduction be performed?
#'  Only used if `object` is a directed acyclic graph.
#' @param remove_multiple A [`logical`] scalar: should multiple edges be
#'  removed?
#' @param remove_loops A [`logical`] scalar: should loop edges be removed?
#' @param ... Currently not used.
#' @return
#'  An \pkg{igraph} graph object.
#' @note
#'  Experimental.
#'
#'  The \pkg{igraph} and \pkg{relations} packages need to be installed on your
#'  machine.
#' @example inst/examples/ex-graph.R
#' @author N. Frerebeau
#' @docType methods
#' @family graph tools
#' @aliases graph_prune-method
setGeneric(
  name = "graph_prune",
  def = function(object, ...) standardGeneric("graph_prune")
)

# Temporal Relations ===========================================================
#' Time Overlap
#'
#' Computes the length of overlap of time intervals.
#' @param x A [`TimeIntervals-class`] object.
#' @param calendar A [`TimeScale-class`] object specifying the target calendar
#'  (see [calendar()]). If `NULL` (the default), *rata die* are returned.
#' @param aggregate A [`logical`] scalar: should disjoint intervals referring to
#'  the same event be aggregated?
#' @param ... Currently not used.
#' @details
#'  The overlap of two time intervals is a difference between the minimum value
#'  of the two upper boundaries and the maximum value of the two lower
#'  boundaries, plus 1.
#' @return
#'  A symmetric `numeric` [`matrix`] of years.
#' @example inst/examples/ex-intervals.R
#' @author N. Frerebeau
#' @docType methods
#' @family temporal relations
#' @aliases overlap-method
setGeneric(
  name = "overlap",
  def = function(x, ...) standardGeneric("overlap")
)

#' Temporal Relations
#'
#' Test for the logical relation between time intervals according to Allen's
#' typology.
#' @param x A [`TimeIntervals-class`] object.
#' @param ... Currently not used.
#' @details
#'  Allen (1983) proposed thirteen basic relations between time intervals that
#'  are (Alspaugh 2019):
#'
#'  * **Distinct**: no pair of definite intervals can be related by more than
#'    one of the relationships.
#'  * **Exhaustive:** any pair of definite intervals are described by one of the
#'    relations.
#'  * **Qualitative:** no numeric time spans are considered.
#'
#' \tabular{lrlr}{
#'  **Relation** \tab     \tab     \tab  **Converse** \cr
#'  precedes     \tab (p) \tab (P) \tab   preceded by \cr
#'  meets        \tab (m) \tab (M) \tab        met by \cr
#'  overlaps     \tab (o) \tab (O) \tab overlapped by \cr
#'  finished by  \tab (F) \tab (f) \tab      finishes \cr
#'  contains     \tab (D) \tab (d) \tab        during \cr
#'  starts       \tab (s) \tab (S) \tab    started by \cr
#'  equals       \tab (e) \tab     \tab               \cr
#' }
#'
#' A *precedes* B
#'
#' ```
#' A ===
#' B     ===
#' ```
#'
#' A *preceded by* B
#'
#' ```
#' A     ===
#' B ===
#' ```
#'
#' A *meets* B
#'
#' ```
#' A ===
#' B    ===
#' ```
#'
#' A *met by* B
#'
#' ```
#' A ===
#' B    ===
#' ```
#'
#' A *overlaps* B
#'
#' ```
#' A ===
#' B   ===
#' ```
#'
#' A *overlapped by* B
#'
#' ```
#' A   ===
#' B ===
#' ```
#'
#' A *finished by* B
#'
#' ```
#' A =====
#' B   ===
#' ```
#'
#' A *finishes* B
#'
#' ```
#' A   ===
#' B =====
#' ```
#'
#' A *contains* B
#'
#' ```
#' A =====
#' B  ===
#' ```
#'
#' A *during* B
#'
#' ```
#' A  ===
#' B =====
#' ```
#'
#' A *starts* B
#'
#' ```
#' A ===
#' B =====
#' ```
#'
#' A *started by* B
#'
#' ```
#' A =====
#' B ===
#' ```
#'
#' A *equals* B
#'
#' ```
#' A ===
#' B ===
#' ```
#'
#' @return
#'  A two-columns `matrix` where each row specifies one relation.
#' @references
#'  Allen, J. F. (1983). Maintaining Knowledge about Temporal Intervals.
#'  *Communications of the ACM*, 26(11): 832-843. \doi{10.1145/182.358434}.
#'
#'  Alspaugh, T. (2019). Allen's Interval Algebra.
#'  URL: \url{https://thomasalspaugh.org/pub/fnd/allen.html}.
#' @example inst/examples/ex-relation.R
#' @author N. Frerebeau
#' @docType methods
#' @family temporal relations
#' @name relations
#' @rdname relations
NULL

#' @rdname relations
#' @aliases precedes-method
setGeneric(
  name = "precedes",
  def = function(x, ...) standardGeneric("precedes")
)

#' @rdname relations
#' @aliases preceded_by-method
setGeneric(
  name = "preceded_by",
  def = function(x, ...) standardGeneric("preceded_by")
)

#' @rdname relations
#' @aliases meets-method
setGeneric(
  name = "meets",
  def = function(x, ...) standardGeneric("meets")
)

#' @rdname relations
#' @aliases met_by-method
setGeneric(
  name = "met_by",
  def = function(x, ...) standardGeneric("met_by")
)

#' @rdname relations
#' @aliases overlaps-method
setGeneric(
  name = "overlaps",
  def = function(x, ...) standardGeneric("overlaps")
)

#' @rdname relations
#' @aliases overlapped_by-method
setGeneric(
  name = "overlapped_by",
  def = function(x, ...) standardGeneric("overlapped_by")
)

#' @rdname relations
#' @aliases finishes-method
setGeneric(
  name = "finishes",
  def = function(x, ...) standardGeneric("finishes")
)

#' @rdname relations
#' @aliases finished_by-method
setGeneric(
  name = "finished_by",
  def = function(x, ...) standardGeneric("finished_by")
)

#' @rdname relations
#' @aliases contains-method
setGeneric(
  name = "contains",
  def = function(x, ...) standardGeneric("contains")
)

#' @rdname relations
#' @aliases during-method
setGeneric(
  name = "during",
  def = function(x, ...) standardGeneric("during")
)

#' @rdname relations
#' @aliases starts-method
setGeneric(
  name = "starts",
  def = function(x, ...) standardGeneric("starts")
)

#' @rdname relations
#' @aliases started_by-method
setGeneric(
  name = "started_by",
  def = function(x, ...) standardGeneric("started_by")
)

#' @rdname relations
#' @aliases equals-method
setGeneric(
  name = "equals",
  def = function(x, ...) standardGeneric("equals")
)

# OPERATORS
#' @include AllGenerics.R
NULL

# "+", "-", "*", "^", "%%", "%/%", "/"
#' @export
#' @rdname arithmetic
#' @aliases Arith,RataDie,RataDie-method
setMethod(
  f = "Arith",
  signature = c(e1 = "RataDie", e2 = "RataDie"),
  definition = function(e1, e2) {
    z <- methods::callGeneric(e1@.Data, e2@.Data)
    switch(
      .Generic[[1]],
      `+` = return(.RataDie(z)),
      `-` = return(.RataDie(z)),
      return(z)
    )
  }
)

#' @export
#' @rdname arithmetic
#' @aliases Arith,numeric,RataDie-method
setMethod(
  f = "Arith",
  signature = c(e1 = "numeric", e2 = "RataDie"),
  definition = function(e1, e2) {
    z <- methods::callGeneric(e1, e2@.Data)
    switch(
      .Generic[[1]],
      `+` = return(.RataDie(z)),
      `-` = return(.RataDie(z)),
      `*` = return(.RataDie(z)),
      return(z)
    )
  }
)

#' @export
#' @rdname arithmetic
#' @aliases Arith,RataDie,numeric-method
setMethod(
  f = "Arith",
  signature = c(e1 = "RataDie", e2 = "numeric"),
  definition = function(e1, e2) {
    z <- methods::callGeneric(e1@.Data, e2)
    switch(
      .Generic[[1]],
      `+` = return(.RataDie(z)),
      `-` = return(.RataDie(z)),
      `*` = return(.RataDie(z)),
      `/` = return(.RataDie(z)),
      return(z)
    )
  }
)

# FORMAT

# Format =======================================================================
#' @export
#' @method format TimeIntervals
format.TimeIntervals <- function(x, calendar = get_calendar(), ...) {
  debut <- start(x, calendar = calendar)
  fin <- end(x, calendar = calendar)

  msg <- sprintf("[%g, %g]", debut, fin)
  trimws(msg)
}

#' @export
#' @rdname format
setMethod("format", "TimeIntervals", format.TimeIntervals)

#' @export
#' @method format TimeScale
format.TimeScale <- function(x, ...) {
  msg <- sprintf("%s %s", calendar_unit(x), calendar_label(x))
  trimws(msg)
}

#' @export
#' @rdname format
setMethod("format", "TimeScale", format.TimeScale)

#' @export
#' @method format RataDie
format.RataDie <- function(x, prefix = c("a", "ka", "Ma", "Ga"), label = TRUE,
                           calendar = get_calendar(), ...) {
  if (is.null(calendar)) return(format(as.numeric(x)))
  y <- as_year(x, calendar = calendar)

  ## Scale
  if (isTRUE(prefix)) {
    power <- 10^floor(log10(abs(mean(y, na.rm = TRUE))))
    if (prefix < 10^4) prefix <- "a"
    if (power >= 10^4 && power < 10^6) prefix <- "ka"
    if (power >= 10^6 && power < 10^9) prefix <- "Ma"
    if (power >= 10^9) prefix <- "Ga"
  }
  prefix <- match.arg(prefix, several.ok = FALSE)
  power <- switch (prefix, ka = 10^3, Ma = 10^6, Ga = 10^9, 1)

  prefix <- if (power > 1) sprintf(" %s", prefix) else ""
  label <- if (isTRUE(label)) sprintf(" %s", calendar_label(calendar)) else ""
  trimws(sprintf("%g%s%s", y / power, prefix, label))
}

#' @export
#' @rdname format
setMethod("format", "RataDie", format.RataDie)

# OVERLAP
#' @include AllGenerics.R
NULL

#' @export
#' @rdname overlap
#' @aliases overlap,TimeIntervals-method
setMethod(
  f = "overlap",
  signature = "TimeIntervals",
  definition = function(x, calendar = NULL, aggregate = TRUE) {
    labels <- labels(x)
    lower <- start(x, calendar = calendar) * calendar_direction(calendar)
    upper <- end(x, calendar = calendar) * calendar_direction(calendar)
    m <- length(x)

    ## Compute overlap
    index <- utils::combn(
      x = seq_len(m),
      m = 2,
      FUN = function(x) max(0, min(upper[x]) - max(lower[x]) + 1)
    )

    ## Matrix of results
    mtx <- matrix(data = upper - lower, nrow = m, ncol = m, dimnames = list(labels, labels))
    mtx[lower.tri(mtx, diag = FALSE)] <- index
    mtx <- t(mtx)
    mtx[lower.tri(mtx, diag = FALSE)] <- index

    ## Aggregate in case of disjoint intervals referring to the same event
    if (isTRUE(aggregate)) {
      mtx <- t(rowsum(mtx, group = labels, reorder = FALSE))
      mtx <- rowsum(mtx, group = labels, reorder = FALSE)
    }

    mtx
  }
)

# COERCION
#' @include AllGenerics.R
NULL

# To RataDie ===================================================================
#' @export
#' @rdname as_fixed
#' @aliases as_fixed,numeric-method
setMethod(
  f = "as_fixed",
  signature = "numeric",
  definition = function(from) .RataDie(from)
)

# To data.frame ================================================================
#' @export
#' @method as.data.frame TimeSeries
as.data.frame.TimeSeries <- function(x, ..., calendar = NULL) {
  ## Fix dimnames (if needed)
  x <- fix_dimnames(x)
  ## Build a long data frame
  data.frame(
    time = time(x, calendar = calendar)[as.vector(slice.index(x, MARGIN = 1L))],
    series = dimnames(x)[[2L]][as.vector(slice.index(x, MARGIN = 2L))],
    variable = dimnames(x)[[3L]][as.vector(slice.index(x, MARGIN = 3L))],
    value = as.vector(x)
  )
}

#' @export
#' @describeIn as.data.frame Returns a long [`data.frame`] with the following columns:
#'  \describe{
#'   \item{`time`}{The sampling times. If `calendar` is not `NULL`, it is
#'   expressed in decimal years; otherwise, it is expressed in *rata die*.}
#'   \item{`series`}{The name of the time series.}
#'   \item{`variable`}{The name of the variables.}
#'   \item{`value`}{The observed value.}
#'  }
#' @aliases as.data.frame,TimeSeries-method
setMethod("as.data.frame", "TimeSeries", as.data.frame.TimeSeries)

#' @export
#' @method as.data.frame TimeIntervals
as.data.frame.TimeIntervals <- function(x, ..., calendar = NULL) {
  ## Build a data frame
  data.frame(
    label = labels(x),
    start = start(x, calendar = calendar),
    end = end(x, calendar = calendar)
  )
}

#' @export
#' @describeIn as.data.frame Returns a [`data.frame`] with the following columns:
#'  \describe{
#'   \item{`label`}{The name of the intervals.}
#'   \item{`start`}{The start time of the intervals. If `calendar` is not
#'   `NULL`, it is expressed in decimal years; otherwise, it is expressed in
#'   *rata die*.}
#'   \item{`end`}{The end time of the intervals. If `calendar` is not `NULL`, it
#'   is expressed in decimal years; otherwise, it is expressed in *rata die*.}
#'  }
#' @aliases as.data.frame,TimeIntervals-method
setMethod("as.data.frame", "TimeIntervals", as.data.frame.TimeIntervals)

# To array =====================================================================
#' @export
#' @method as.array TimeSeries
as.array.TimeSeries <- function(x, ...) {
  methods::as(x, "array")
}

#' @export
#' @rdname as.array
#' @aliases as.array,TimeSeries-method
setMethod("as.array", "TimeSeries", as.array.TimeSeries)

# YEAR
#' @include AllGenerics.R
NULL

# Decimal years ================================================================
#' @export
#' @rdname as_decimal
#' @aliases as_decimal,numeric,numeric,numeric,GregorianCalendar-method
setMethod(
  f = "as_decimal",
  signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "GregorianCalendar"),
  definition = function(year, month, day, calendar) {
    ## Shift origin
    year <- (year - calendar_epoch(calendar)) * calendar_direction(calendar)

    .as_decimal(year, month, day, calendar)
  }
)

#' @export
#' @rdname as_decimal
#' @aliases as_decimal,numeric,numeric,numeric,JulianCalendar-method
setMethod(
  f = "as_decimal",
  signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "JulianCalendar"),
  definition = function(year, month, day, calendar) {
    .as_decimal(year, month, day, calendar)
  }
)

.as_decimal <- function(year, month, day, calendar) {
  ## Year length in days
  start <- fixed(year, 01, 01, calendar = calendar)
  end <- fixed(year, 12, 31, calendar = calendar)
  total <- end - start + 1

  ## Elapsed time
  date <- fixed(year, month, day, calendar = calendar)
  sofar <- date - start

  unclass(year + sofar / total)
}

# Leap year ====================================================================
is_julian_leap_year <- function(year) {
  year <- floor(year) # Drop decimal part (if any)
  leap <- year %% 4 == 3
  leap[year > 0] <- year[year > 0] %% 4 == 0
  leap
}

is_gregorian_leap_year <- function(year) {
  year <- floor(year) # Drop decimal part (if any)
  ((year %% 4) == 0) &
    (year %% 400 != 100) &
    (year %% 400 != 200) &
    (year %% 400 != 300)
}

# MUTATORS
#' @include AllGenerics.R
NULL

# Getters ======================================================================
#' @export
#' @method labels TimeSeries
labels.TimeSeries <- function(object, ...) colnames(object)

#' @rdname labels
#' @aliases labels,TimeSeries-method
setMethod("labels", "TimeSeries", labels.TimeSeries)

#' @export
#' @method labels TimeIntervals
labels.TimeIntervals <- function(object, ...) object@.Id

#' @rdname labels
#' @aliases labels,TimeIntervals-method
setMethod("labels", "TimeIntervals", labels.TimeIntervals)

#' @export
#' @method names TimeIntervals
names.TimeIntervals <- function(x) x@.Id

#' @rdname names
#' @aliases names,TimeIntervals-method
setMethod("names", "TimeIntervals", names.TimeIntervals)

#' @export
#' @method length TimeIntervals
length.TimeIntervals <- function(x) length(x@.Id)

#' @rdname length
#' @aliases length,TimeIntervals-method
setMethod("length", "TimeIntervals", length.TimeIntervals)

# Setters ======================================================================
#' @export
#' @method `names<-` TimeIntervals
`names<-.TimeIntervals` <- function(x, value) {
  if (is.null(value)) value <- paste0("I", seq_len(length(x)))
  x@.Id <- as.character(value)
  validObject(x)
  x
}

#' @rdname names
#' @aliases names<-,TimeIntervals-method
setMethod("names<-", "TimeIntervals", `names<-.TimeIntervals`)

# SPAN
#' @include AllGenerics.R
NULL

#' @export
#' @rdname span
#' @aliases span,TimeSeries-method
setMethod(
  f = "span",
  signature = c(x = "TimeSeries"),
  definition = function(x, calendar = NULL) {
    z <- end(x, calendar = calendar) - start(x, calendar = calendar)
    unclass(z) * calendar_direction(calendar)
  }
)

#' @export
#' @rdname span
#' @aliases span,TimeIntervals-method
setMethod(
  f = "span",
  signature = c(x = "TimeIntervals"),
  definition = function(x, calendar = NULL) {
    z <- end(x, calendar = calendar) - start(x, calendar = calendar)
    unclass(z) * calendar_direction(calendar)
  }
)

# CLASSES VALIDATION
#' @include AllClasses.R
NULL

# TimeScale =====================================================================
setValidity(
  Class = "TimeScale",
  method = function(object) {
    ## Get data
    label <- object@label
    name <- object@name
    epoch <- object@epoch
    fixed <- object@fixed
    direction <- object@direction
    year <- object@year

    ## Validate
    cnd <- list(
      arkhe::validate(arkhe::assert_length(label, 1)),
      arkhe::validate(arkhe::assert_length(name, 1)),
      arkhe::validate(arkhe::assert_length(epoch, 1)),
      arkhe::validate(arkhe::assert_length(fixed, 1)),
      arkhe::validate(arkhe::assert_length(direction, 1)),
      arkhe::validate(arkhe::assert_length(year, 1))
    )

    ## Return conditions, if any
    arkhe::check_class(object, cnd)
  }
)

# Time Series ==================================================================
# setValidity(
#   Class = "RataDie",
#   method = function(object) {
#
#   }
# )

setValidity(
  Class = "TimeSeries",
  method = function(object) {
    ## Get data
    time <- object@.Time
    m <- nrow(object)

    ## Validate
    cnd <- list(
      arkhe::validate(arkhe::assert_type(object, "numeric")),
      arkhe::validate(arkhe::assert_length(time, m)),
      arkhe::validate(arkhe::assert_infinite(time))
    )

    ## Return conditions, if any
    arkhe::check_class(object, cnd)
  }
)

setValidity(
  Class = "TimeIntervals",
  method = function(object) {
    ## Get data
    names <- object@.Id
    start <- object@.Start
    end <- object@.End
    m <- length(start)

    ## Validate
    cnd <- list(
      arkhe::validate(arkhe::assert_length(names, m)),
      arkhe::validate(arkhe::assert_length(end, m)),
      arkhe::validate(arkhe::assert_missing(names)),
      arkhe::validate(arkhe::assert_missing(start)),
      arkhe::validate(arkhe::assert_missing(end)),
      arkhe::validate(assert_ordered(start, end))
    )

    ## Return conditions, if any
    arkhe::check_class(object, cnd)
  }
)

assert_ordered <- function(start, end) {
  arg_start <- deparse(substitute(start))
  arg_end <- deparse(substitute(end))
  if (any(start > end)) {
    msg <- sprintf(tr_("%s is later than %s."), sQuote(arg_start), sQuote(arg_end))
    stop(msg)
  }
  invisible(NULL)
}

1		# SUBSET
2		#' @include AllGenerics.R
3		NULL
4
5		# Extract ======================================================================
6		## [ ---------------------------------------------------------------------------
7		#' @export
8		#' @rdname subset
9		#' @aliases [,RataDie-method
10		setMethod(
11		f = "[",
12		signature = c(x = "RataDie"),
13		function(x, i) {
14	322x	z <- methods::callNextMethod() # Method for `numeric`
15	322x	methods::initialize(x, z)
16		}
17		)
18
19		#' @export
20		#' @rdname subset
21		#' @aliases [,TimeIntervals-method
22		setMethod(
23		f = "[",
24		signature = c(x = "TimeIntervals"),
25		function(x, i) {
26	!	id <- x@.Id[i]
27	!	start <- x@.Start[i]
28	!	end <- x@.End[i]
29	!	methods::initialize(x, .Id = id, .Start = start, .End = end)
30		}
31		)
32
33		#' @export
34		#' @rdname subset
35		#' @aliases [,TimeSeries-method
36		setMethod(
37		f = "[",
38		signature = c(x = "TimeSeries"),
39		function(x, i, j, k, drop = FALSE) {
40	77x	z <- x@.Data
41	77x	time <- x@.Time
42
43	77x	z <- z[i, j, k, drop = drop]
44	42x	if (isTRUE(drop)) return(z)
45
46	35x	if (!missing(i)) {
47	!	if (is.character(i)) i <- match(i, dimnames(x)[1L])
48	4x	time <- time[i]
49		}
50
51	35x	methods::initialize(x, z, .Time = time)
52		}
53		)
54
55		# Transpose ====================================================================
56		#' @export
57		#' @rdname flip
58		#' @aliases flip,TimeSeries-method
59		setMethod(
60		f = "flip",
61		signature = c(x = "TimeSeries"),
62		function(x) {
63	2x	z <- x@.Data
64	2x	z <- fix_dimnames(z) # Fix dimnames (if needed)
65	2x	z <- aperm(z, perm = c(1, 3, 2), resize = TRUE)
66
67	2x	methods::initialize(x, z)
68		}
69		)
70
71		# Window =======================================================================
72		#' @export
73		#' @method window TimeSeries
74		window.TimeSeries <- function(x, start = NULL, end = NULL, ...) {
75	1x	if (is.null(start)) start <- start(x)
76	1x	if (is.null(end)) end <- end(x)
77	3x	years <- time(x)
78
79	3x	i <- which(years >= start & years <= end)
80	3x	x[i, , , drop = FALSE]
81		}
82
83		#' @export
84		#' @rdname window
85		#' @aliases window,TimeSeries-method
86		setMethod("window", "TimeSeries", window.TimeSeries)

1		# CONVERT
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname convert
7		#' @aliases convert,character,character-method
8		setMethod(
9		f = "convert",
10		signature = c(from = "character", to = "character"),
11		definition = function(from, to) {
12	2x	methods::callGeneric(from = calendar(from), to = calendar(to))
13		}
14		)
15
16		#' @export
17		#' @rdname convert
18		#' @aliases convert,TimeScale,TimeScale-method
19		setMethod(
20		f = "convert",
21		signature = c(from = "TimeScale", to = "TimeScale"),
22		definition = function(from, to) {
23		## TODO: validation
24
25	2x	fun <- function(x) {
26	2x	a <- fixed(x, month = 01, day = 01, calendar = from)
27	2x	b <- as_year(a, calendar = to, decimal = TRUE)
28	2x	return(b)
29		}
30
31	2x	return(fun)
32		}
33		)

1		# GREGORIAN CALENDAR
2		#' @include AllGenerics.R
3		NULL
4
5		# Fixed from Gregorian =========================================================
6		#' @export
7		#' @rdname fixed
8		#' @aliases fixed,numeric,missing,missing,GregorianCalendar-method
9		setMethod(
10		f = "fixed",
11		signature = c(year = "numeric", month = "missing", day = "missing", calendar = "GregorianCalendar"),
12		definition = function(year, calendar, scale = 1) {
13		## Rescale to years (if not already)
14	69x	year <- year * scale
15
16	69x	rd <- fixed(year, 01, 01, calendar = calendar)
17
18	69x	is_leap <- which(is_gregorian_leap_year(year))
19	69x	rd[is_leap] <- ceiling(rd[is_leap]) # WHY ???
20	69x	rd
21		}
22		)
23
24		#' @export
25		#' @rdname fixed
26		#' @aliases fixed,numeric,numeric,numeric,GregorianCalendar-method
27		setMethod(
28		f = "fixed",
29		signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "GregorianCalendar"),
30		definition = function(year, month, day, calendar) {
31		## Recycle
32	359x	n <- length(year)
33	359x	if (n > 1) {
34	277x	if (length(month) == 1) month <- rep(month, n)
35	279x	if (length(day) == 1) day <- rep(day, n)
36		}
37
38		## Switch origin
39	359x	year <- (year - calendar_epoch(calendar)) * calendar_direction(calendar)
40
41		## Correct for 28- or 29-day Feb
42	359x	correction <- rep(-2, length(year))
43	359x	correction[is_gregorian_leap_year(year)] <- -1
44	359x	correction[month <= 2] <- 0
45
46	359x	rd <- calendar_fixed(calendar) - 1 + # Days before start of calendar
47	359x	365 * (year - 1) + # Ordinary days since epoch
48	359x	(year - 1) %/% 4 - # Julian leap days since epoch minus...
49	359x	(year - 1) %/% 100 + # ...century years since epoch plus...
50	359x	(year - 1) %/% 400 + # ...years since epoch divisible by 400
51	359x	(367 * month - 362) %/% 12 + # Days in prior months this year assuming 30-day Feb
52	359x	correction + # Correct for 28- or 29-day Feb
53	359x	day # Days so far this month.
54
55		## Fix infinite values
56	359x	rd[is.infinite(year)] <- year[is.infinite(year)]
57
58	359x	.RataDie(rd)
59		}
60		)
61		# Gregorian from fixed =========================================================
62		#' @export
63		#' @rdname as_year
64		#' @aliases as_year,numeric,GregorianCalendar-method
65		setMethod(
66		f = "as_year",
67		signature = c(object = "numeric", calendar = "GregorianCalendar"),
68		definition = function(object, calendar, decimal = TRUE, ...) {
69	144x	d0 <- object - calendar_fixed(calendar)
70	144x	n400 <- d0 %/% 146097
71	144x	d1 <- d0 %% 146097
72	144x	n100 <- d1 %/% 36524
73	144x	d2 <- d1 %% 36524
74	144x	n4 <- d2 %/% 1461
75	144x	d3 <- d2 %% 1461
76	144x	n1 <- d3 %/% 365
77
78	144x	year <- 400 * n400 + 100 * n100 + 4 * n4 + n1
79	144x	year <- ifelse(n100 == 4 \| n1 == 4, year, year + 1)
80
81		## Shift origin
82	144x	year <- (year - calendar_epoch(calendar)) * calendar_direction(calendar)
83
84	144x	if (isTRUE(decimal)) {
85		## Year length in days
86	118x	start <- fixed(year, 01, 01, calendar = calendar)
87	118x	end <- fixed(year, 12, 31, calendar = calendar)
88	118x	total <- end - start + 1
89
90		## Elapsed time
91	118x	sofar <- object - start
92
93	118x	year <- year + sofar / total
94		}
95
96		## Fix infinite values
97	144x	year[is.infinite(object)] <- object[is.infinite(object)]
98
99	144x	year
100		}
101		)
102
103		#' @export
104		#' @rdname as_date
105		#' @aliases as_date,numeric,GregorianCalendar-method
106		setMethod(
107		f = "as_date",
108		signature = c(object = "numeric", calendar = "GregorianCalendar"),
109		definition = function(object, calendar) {
110	9x	year <- as_year(object, calendar = calendar, decimal = FALSE)
111	9x	prior_days <- object - fixed(year, 01, 01, calendar = calendar)
112
113	9x	correction <- rep(2, length(object))
114	9x	correction[object < fixed(year, 03, 01, calendar = calendar)] <- 0
115	9x	correction[is_gregorian_leap_year(year)] <- 1
116
117	9x	month <- (12 * (prior_days + correction) + 373) %/% 367
118	9x	day <- object - fixed(year, month, 01, calendar = calendar) + 1
119
120	9x	data.frame(
121	9x	year = as.numeric(year),
122	9x	month = as.numeric(month),
123	9x	day = as.numeric(day)
124		)
125		}
126		)
127
128		# Era ==========================================================================
129		#' @export
130		#' @rdname fixed_gregorian
131		fixed_from_BP <- function(year, month, day) {
132	!	if (missing(month) \|\| missing(day)) fixed(year, calendar = BP())
133	!	else fixed(year, month, day, calendar = BP())
134		}
135		#' @export
136		#' @rdname fixed_gregorian
137		fixed_to_BP <- function(object) {
138	1x	as_year(object, calendar = BP(), decimal = TRUE)
139		}
140
141		#' @export
142		#' @rdname fixed_gregorian
143		fixed_from_BC <- function(year, month, day) {
144	!	if (missing(month) \|\| missing(day)) fixed(year, calendar = BC())
145	!	else fixed(year, month, day, calendar = BC())
146		}
147		#' @export
148		#' @rdname fixed_gregorian
149		fixed_to_BC <- function(object) {
150	1x	as_year(object, calendar = BC(), decimal = TRUE)
151		}
152
153		#' @export
154		#' @rdname fixed_gregorian
155		fixed_from_BCE <- function(year, month, day) {
156	!	if (missing(month) \|\| missing(day)) fixed(year, calendar = BCE())
157	!	else fixed(year, month, day, calendar = BCE())
158		}
159		#' @export
160		#' @rdname fixed_gregorian
161		fixed_to_BCE <- function(object) {
162	2x	as_year(object, calendar = BCE(), decimal = TRUE)
163		}
164
165		#' @export
166		#' @rdname fixed_gregorian
167		fixed_from_AD <- function(year, month, day) {
168	!	if (missing(month) \|\| missing(day)) fixed(year, calendar = AD())
169	15x	else fixed(year, month, day, calendar = AD())
170		}
171		#' @export
172		#' @rdname fixed_gregorian
173		fixed_to_AD <- function(object) {
174	1x	as_year(object, calendar = AD(), decimal = TRUE)
175		}
176
177		#' @export
178		#' @rdname fixed_gregorian
179		fixed_from_CE <- function(year, month, day) {
180	!	if (missing(month) \|\| missing(day)) fixed(year, calendar = CE())
181	!	else fixed(year, month, day, calendar = CE())
182		}
183		#' @export
184		#' @rdname fixed_gregorian
185		fixed_to_CE <- function(object) {
186	1x	as_year(object, calendar = CE(), decimal = TRUE)
187		}
188
189		#' @export
190		#' @rdname fixed_gregorian
191		fixed_from_b2k <- function(year, month, day) {
192	!	if (missing(month) \|\| missing(day)) fixed(year, calendar = b2k())
193	!	else fixed(year, month, day, calendar = b2k())
194		}
195		#' @export
196		#' @rdname fixed_gregorian
197		fixed_to_b2k <- function(object) {
198	1x	as_year(object, calendar = b2k(), decimal = TRUE)
199		}

1		# SHOW
2
3		# Show =========================================================================
4		setMethod(
5		f = "show",
6		signature = "TimeScale",
7		definition = function(object) {
8	!	cal_name <- calendar_name(object)
9	!	cal_label <- calendar_label(object)
10	!	has_name <- length(cal_name) == 1 && nzchar(cal_name)
11	!	has_label <- length(cal_label) == 1 && nzchar(cal_label)
12
13	!	era <- ""
14	!	if (has_name && has_label) {
15	!	era <- sprintf("%s (%s): ", cal_name, cal_label)
16		}
17
18	!	if (calendar_direction(object) > 0) {
19	!	msg <- tr_("%s%s counted forwards from %g")
20		} else {
21	!	msg <- tr_("%s%s counted backwards from %g")
22		}
23	!	msg <- sprintf(msg, era, calendar_unit(object), calendar_epoch(object))
24	!	cat(trimws(msg), sep = "\n")
25		}
26		)
27
28		setMethod(
29		f = "show",
30		signature = "RataDie",
31		definition = function(object) {
32	!	msg <- tr_("Rata die: number of days since 01-01-01 (Gregorian)")
33	!	cat(msg, sep = "\n")
34	!	methods::callGeneric(object@.Data)
35		}
36		)
37
38		setMethod(
39		f = "show",
40		signature = "TimeSeries",
41		definition = function(object) {
42	!	n <- dim(object)
43	!	k <- n[[2]] + n[[3]] - 1
44	!	start <- format(as_fixed(start(object)))
45	!	end <- format(as_fixed(end(object)))
46	!	msg <- ngettext(k, "%d x %d x %d time series observed between %s and %s",
47	!	"%d x %d x %d time series observed between %s and %s")
48	!	msg <- sprintf(msg, n[[1L]], n[[2L]], n[[3L]], start, end)
49	!	cat(msg, sep = "\n")
50		}
51		)
52
53		setMethod(
54		f = "show",
55		signature = "TimeIntervals",
56		definition = function(object) {
57	!	n <- length(object)
58	!	start <- format(as_fixed(min(start(object))))
59	!	end <- format(as_fixed(max(end(object))))
60	!	msg <- ngettext(n, "%d time interval observed between %s and %s",
61	!	"%d time intervals observed between %s and %s")
62	!	msg <- sprintf(msg, n, start, end)
63	!	cat(msg, sep = "\n")
64		}
65		)

1		# TIME SERIES
2		#' @include AllGenerics.R
3		NULL
4
5		# array ========================================================================
6		#' @export
7		#' @rdname series
8		#' @aliases series,array,RataDie,missing-method
9		setMethod(
10		f = "series",
11		signature = c(object = "array", time = "RataDie", calendar = "missing"),
12		definition = function(object, time, names = NULL) {
13		## Validation
14	20x	arkhe::assert_length(time, NROW(object))
15
16		## Set the names of the series
17	20x	n <- dim(object)[[2L]]
18	20x	if (!is.null(names)) {
19	2x	arkhe::assert_length(names, n)
20	2x	dimnames(object)[[2L]] <- names
21		}
22	20x	if (is.null(dimnames(object)[[2L]])) {
23	14x	dimnames(object)[[2L]] <- paste0("S", seq_len(n))
24		}
25
26		## Chronological order
27	20x	i <- order(time, decreasing = FALSE)
28	20x	time <- time[i]
29	20x	object <- object[i, , , drop = FALSE]
30
31	20x	.TimeSeries(object, .Time = time)
32		}
33		)
34
35		#' @export
36		#' @rdname series
37		#' @aliases series,array,numeric,TimeScale-method
38		setMethod(
39		f = "series",
40		signature = c(object = "array", time = "numeric", calendar = "TimeScale"),
41		definition = function(object, time, calendar, scale = 1, names = NULL) {
42	11x	if (methods::is(time, "RataDie")) {
43	1x	msg <- tr_("%s is already expressed in rata die: %s is ignored.")
44	1x	warning(sprintf(msg, sQuote("time"), sQuote("calendar")), call. = FALSE)
45		} else {
46	10x	time <- fixed(time, calendar = calendar, scale = scale)
47		}
48	11x	methods::callGeneric(object = object, time = time, names = names)
49		}
50		)
51
52		# matrix =======================================================================
53		#' @export
54		#' @rdname series
55		#' @aliases series,matrix,numeric,TimeScale-method
56		setMethod(
57		f = "series",
58		signature = c(object = "matrix", time = "numeric", calendar = "TimeScale"),
59		definition = function(object, time, calendar, scale = 1, names = NULL) {
60	9x	x <- array(object, dim = c(dim(object), 1))
61	9x	rownames(x) <- rownames(object)
62	9x	colnames(x) <- colnames(object)
63	9x	methods::callGeneric(object = x, time = time, calendar = calendar,
64	9x	scale = scale, names = names)
65		}
66		)
67
68		#' @export
69		#' @rdname series
70		#' @aliases series,matrix,RataDie,missing-method
71		setMethod(
72		f = "series",
73		signature = c(object = "matrix", time = "RataDie", calendar = "missing"),
74		definition = function(object, time, names = NULL) {
75	4x	x <- array(object, dim = c(dim(object), 1))
76	4x	colnames(x) <- colnames(object)
77	4x	methods::callGeneric(object = x, time = time, names = names)
78		}
79		)
80
81		# numeric ======================================================================
82		#' @export
83		#' @rdname series
84		#' @aliases series,numeric,numeric,TimeScale-method
85		setMethod(
86		f = "series",
87		signature = c(object = "numeric", time = "numeric", calendar = "TimeScale"),
88		definition = function(object, time, calendar, scale = 1, names = NULL) {
89	1x	object <- array(data = object, dim = c(length(object), 1, 1))
90	1x	methods::callGeneric(object = object, time = time, calendar = calendar,
91	1x	scale = scale, names = names)
92		}
93		)
94
95		#' @export
96		#' @rdname series
97		#' @aliases series,numeric,RataDie,missing-method
98		setMethod(
99		f = "series",
100		signature = c(object = "numeric", time = "RataDie", calendar = "missing"),
101		definition = function(object, time, names = NULL) {
102	5x	object <- array(data = object, dim = c(length(object), 1, 1))
103	5x	methods::callGeneric(object = object, time = time, names = names)
104		}
105		)
106
107		# data.frame ===================================================================
108		#' @export
109		#' @rdname series
110		#' @aliases series,data.frame,numeric,TimeScale-method
111		setMethod(
112		f = "series",
113		signature = c(object = "data.frame", time = "numeric", calendar = "TimeScale"),
114		definition = function(object, time, calendar, scale = 1, names = NULL) {
115	1x	object <- data.matrix(object)
116	1x	methods::callGeneric(object = object, time = time, calendar = calendar,
117	1x	scale = scale, names = names)
118		}
119		)
120
121		#' @export
122		#' @rdname series
123		#' @aliases series,data.frame,RataDie,missing-method
124		setMethod(
125		f = "series",
126		signature = c(object = "data.frame", time = "RataDie", calendar = "missing"),
127		definition = function(object, time, names = NULL) {
128	1x	object <- data.matrix(object)
129	1x	methods::callGeneric(object = object, time = time, names = names)
130		}
131		)

1		# PLOT
2		#' @include AllGenerics.R
3		NULL
4
5		# Plot =========================================================================
6		#' @export
7		#' @method plot TimeIntervals
8		plot.TimeIntervals <- function(x, calendar = get_calendar(), groups = NULL,
9		sort = TRUE, decreasing = FALSE,
10		xlab = NULL, ylab = NULL,
11		main = NULL, sub = NULL,
12		ann = graphics::par("ann"), axes = TRUE,
13		frame.plot = axes,
14		panel.first = NULL, panel.last = NULL, ...) {
15		## Save calendar for further use, e.g. year_axis()
16	4x	assign("last_calendar", value = function(...) calendar, envir = the)
17
18		## Get data
19	4x	lab <- labels(x)
20	4x	int <- as.data.frame(x, calendar = calendar)
21	4x	k <- nrow(int)
22	4x	if (is.null(groups)) groups <- rep("", k)
23	4x	arkhe::assert_length(groups, k)
24
25		## Graphical parameters
26	4x	dots <- list(...)
27	4x	col <- make_par(dots, "col", k)
28	4x	lwd <- make_par(dots, "lwd", k)
29	4x	lty <- make_par(dots, "lty", k)
30
31		## Sort and split
32	4x	if (sort) {
33	4x	i <- order(groups, start(x), end(x), decreasing = decreasing)
34		} else {
35	!	i <- order(groups, decreasing = decreasing)
36		}
37	4x	int <- int[i, , drop = FALSE]
38	4x	lab <- lab[i]
39	4x	f <- factor(x = lab, levels = unique(lab), ordered = TRUE)
40	4x	int <- split(x = int, f = f)
41	4x	col <- split(x = col[i], f = f)
42	4x	lwd <- split(x = lwd[i], f = f)
43	4x	lty <- split(x = lty[i], f = f)
44	4x	n <- length(int)
45
46		## Open new window
47	4x	grDevices::dev.hold()
48	4x	on.exit(grDevices::dev.flush(), add = TRUE)
49	4x	graphics::plot.new()
50
51		## Set plotting coordinates
52	4x	xlim <- xlim(x, calendar = calendar, finite = TRUE)
53	4x	ylim <- c(1, n)
54	4x	graphics::plot.window(xlim = xlim, ylim = ylim)
55
56		## Evaluate pre-plot expressions
57	4x	panel.first
58
59		## Plot
60	4x	for (i in seq_len(n)) {
61	48x	x0 <- int[[i]]$start
62	48x	x1 <- int[[i]]$end
63
64		## Fix infinite boundaries
65	48x	x0[is.infinite(x0)] <- graphics::par("usr")[[1L]]
66	48x	x1[is.infinite(x1)] <- graphics::par("usr")[[2L]]
67
68		## Draw segments
69	48x	graphics::segments(x0 = x0, x1 = x1, y0 = i, y1 = i,
70	48x	col = col[[i]], lty = lty[[i]], lwd = lwd[[i]], lend = 1)
71		}
72
73		## Evaluate post-plot and pre-axis expressions
74	4x	panel.last
75
76		## Construct Axis
77	4x	if (axes) {
78	4x	year_axis(side = 1, format = TRUE, calendar = calendar)
79	4x	graphics::axis(side = 2, at = seq_len(n), labels = names(int),
80	4x	lty = 0, las = 1)
81		}
82
83		## Plot frame
84	4x	if (frame.plot) {
85	4x	graphics::box()
86		}
87
88		## Add annotation
89	4x	if (ann) {
90	4x	if (is.null(calendar)) {
91	1x	cal_lab <- expression(italic("rata die"))
92		} else {
93	3x	cal_lab <- format(calendar)
94		}
95	4x	xlab <- xlab %\|\|% cal_lab
96	4x	graphics::title(main = main, sub = sub, xlab = xlab, ylab = ylab)
97		}
98
99	4x	invisible(x)
100		}
101
102		#' @export
103		#' @rdname plot
104		#' @aliases plot,TimeIntervals,missing-method
105		setMethod("plot", c(x = "TimeIntervals", y = "missing"), plot.TimeIntervals)
106
107		#' @export
108		#' @method plot TimeSeries
109		plot.TimeSeries <- function(x, facet = c("multiple", "single"),
110		calendar = get_calendar(),
111		panel = graphics::lines, flip = FALSE, ncol = NULL,
112		xlab = NULL, ylab = NULL,
113		main = NULL, sub = NULL,
114		ann = graphics::par("ann"), axes = TRUE,
115		frame.plot = axes,
116		panel.first = NULL, panel.last = NULL, ...) {
117		## Validation
118	9x	facet <- match.arg(facet, several.ok = FALSE)
119
120		## Save calendar for further use, e.g. year_axis()
121	9x	assign("last_calendar", value = function(...) calendar, envir = the)
122
123	9x	n <- dim(x)[2L]
124
125	9x	if (facet == "multiple" && n > 1) {
126	5x	.plot_multiple(x, calendar = calendar, panel = panel, y_flip = flip,
127	5x	n_col = ncol, xlab = xlab, ylab = ylab,
128	5x	main = main, sub = sub, ann = ann, axes = axes,
129	5x	frame.plot = frame.plot, panel.first = panel.first,
130	5x	panel.last = panel.last, ...)
131		} else {
132	4x	.plot_single(x, calendar = calendar, panel = panel,
133	4x	xlab = xlab, ylab = ylab,
134	4x	main = main, sub = sub,
135	4x	ann = ann, axes = axes,
136	4x	frame.plot = frame.plot, panel.first = panel.first,
137	4x	panel.last = panel.last, ...)
138		}
139
140	9x	invisible(x)
141		}
142
143		#' @export
144		#' @rdname plot
145		#' @aliases plot,TimeSeries,missing-method
146		setMethod("plot", c(x = "TimeSeries", y = "missing"), plot.TimeSeries)
147
148		#' Single Panel Plot
149		#'
150		#' @param x A [`TimeSeries-class`] object.
151		#' @param calendar A [`TimeScale-class`] object specifying the target calendar
152		#' (see [calendar()]).
153		#' @param panel A [`function`] in the form `function(x, y, ...)`
154		#' which gives the action to be carried out in each panel of the display.
155		#' The default is [graphics::lines()].
156		#' @param xlim,ylim A length-two [`numeric`] vector specifying the the x and y
157		#' limits.
158		#' @param main A [`character`] string giving a main title for the plot.
159		#' @param sub A [`character`] string giving a subtitle for the plot.
160		#' @param ann A [`logical`] scalar: should the default annotation (title and x
161		#' and y axis labels) appear on the plot?
162		#' @param axes A [`logical`] scalar: should axes be drawn on the plot?
163		#' @param frame.plot A [`logical`] scalar: should a box be drawn around the
164		#' plot?
165		#' @param panel.first An an `expression` to be evaluated after the plot axes are
166		#' set up but before any plotting takes place. This can be useful for drawing
167		#' background grids.
168		#' @param panel.last An `expression` to be evaluated after plotting has taken
169		#' place but before the axes, title and box are added.
170		#' @param ... Further parameters to be passed to `panel`
171		#' (e.g. [graphical parameters][graphics::par]).
172		#' @return
173		#' Called for its side-effects: it results in a graphic being displayed.
174		#' Invisibly returns `x`.
175		#' @keywords internal
176		#' @noRd
177		.plot_single <- function(x, calendar, panel = graphics::lines,
178		xlab = NULL, ylab = NULL,
179		xlim = NULL, ylim = NULL,
180		main = NULL, sub = NULL,
181		ann = graphics::par("ann"), axes = TRUE,
182		frame.plot = axes,
183		panel.first = NULL, panel.last = NULL, ...) {
184	34x	n_series <- dim(x)[2L]
185	34x	n_dim <- dim(x)[3L]
186
187		## Graphical parameters
188	34x	dots <- list(...)
189	34x	col <- make_par(dots, "col", n = n_dim)
190	34x	bg <- make_par(dots, "bg", n = n_dim)
191	34x	pch <- make_par(dots, "pch", n = n_dim)
192	34x	cex <- make_par(dots, "cex", n = n_dim)
193	34x	lwd <- make_par(dots, "lwd", n = n_dim)
194	34x	lty <- make_par(dots, "lty", n = n_dim)
195
196		## Open new window
197	34x	grDevices::dev.hold()
198	34x	on.exit(grDevices::dev.flush(), add = TRUE)
199	34x	graphics::plot.new()
200
201		## Set plotting coordinates
202	34x	years <- time(x, calendar = calendar)
203	34x	xlim <- xlim %\|\|% xlim(x, calendar = calendar)
204	34x	ylim <- ylim %\|\|% range(x, na.rm = TRUE)
205	34x	graphics::plot.window(xlim = xlim, ylim = ylim)
206
207		## Evaluate pre-plot expressions
208	34x	panel.first
209
210		## Plot
211	34x	for (j in seq_len(n_series)) {
212	39x	for (k in seq_len(n_dim)) {
213	39x	params <- list(col = col[k], bg = bg[k], pch = pch[k],
214	39x	cex = cex[k], lwd = lwd[k], lty = lty[k])
215	39x	dots <- utils::modifyList(dots, params)
216	39x	args <- c(list(x = years, y = x[, j = j, k = k, drop = TRUE]), dots)
217	39x	do.call(panel, args)
218		}
219		}
220
221		## Evaluate post-plot and pre-axis expressions
222	34x	panel.last
223
224		## Construct Axis
225	34x	if (axes) {
226	1x	year_axis(side = 1, format = TRUE, calendar = calendar)
227	1x	graphics::axis(side = 2, las = 1)
228		}
229
230		## Plot frame
231	34x	if (frame.plot) {
232	31x	graphics::box()
233		}
234
235		## Add annotation
236	34x	if (ann) {
237	4x	if (is.null(calendar)) {
238	!	cal_lab <- expression(italic("rata die"))
239		} else {
240	4x	cal_lab <- format(calendar)
241		}
242	4x	xlab <- xlab %\|\|% cal_lab
243	4x	graphics::title(main = main, sub = sub, xlab = xlab, ylab = ylab)
244		}
245
246	34x	invisible(x)
247		}
248
249		#' Multiple Panels Plot
250		#'
251		#' @param x A [`TimeSeries-class`] object.
252		#' @param calendar A [`TimeScale-class`] object specifying the target calendar
253		#' (see [calendar()]).
254		#' @param panel A [`function`] in the form `function(x, y, ...)`
255		#' which gives the action to be carried out in each panel of the display.
256		#' The default is [graphics::lines()].
257		#' @param y_flip A [`logical`] scalar: should the y-axis (ticks and numbering)
258		#' be flipped from side 2 (left) to 4 (right) from series to series?
259		#' @param y_fixed A [`logical`] scalar: should the y-scale be shared across
260		#' all series?
261		#' @param ncol An [`integer`] specifying the number of columns to use.
262		#' Defaults to 1 for up to 4 series, otherwise to 2.
263		#' @param main A [`character`] string giving a main title for the plot.
264		#' @param sub A [`character`] string giving a subtitle for the plot.
265		#' @param ann A [`logical`] scalar: should the default annotation (title and x
266		#' and y axis labels) appear on the plot?
267		#' @param axes A [`logical`] scalar: should axes be drawn on the plot?
268		#' @param frame.plot A [`logical`] scalar: should a box be drawn around the
269		#' plot?
270		#' @param panel.first An an `expression` to be evaluated after the plot axes are
271		#' set up but before any plotting takes place. This can be useful for drawing
272		#' background grids.
273		#' @param panel.last An `expression` to be evaluated after plotting has taken
274		#' place but before the axes, title and box are added.
275		#' @param ... Further parameters to be passed to `panel`
276		#' (e.g. [graphical parameters][graphics::par]).
277		#' @return
278		#' Called for its side-effects: it results in a graphic being displayed.
279		#' Invisibly returns `x`.
280		#' @keywords internal
281		#' @noRd
282		.plot_multiple <- function(x, calendar, panel = graphics::lines,
283		y_flip = TRUE, y_fixed = FALSE, n_col = NULL,
284		xlab = NULL, ylab = NULL,
285		main = NULL, sub = NULL,
286		ann = graphics::par("ann"), axes = TRUE,
287		frame.plot = axes,
288		panel.first = NULL, panel.last = NULL, ...) {
289
290	5x	panel <- match.fun(panel)
291	5x	n <- dim(x)[2L]
292	5x	m <- dim(x)[3L]
293	5x	n_seq <- seq_len(n)
294	5x	m_seq <- seq_len(m)
295	4x	if (is.null(n_col)) n_col <- if (n > 4) 2 else 1
296	5x	n_row <- ceiling(n / n_col)
297
298		## Graphical parameters
299		## Save and restore
300	5x	old_par <- graphics::par(
301	5x	mar = c(0, 5.1, 0, if (y_flip) 5.1 else 2.1),
302	5x	oma = c(6, 0, 5, 0),
303	5x	mfcol = c(n_row, n_col)
304		)
305	5x	on.exit(graphics::par(old_par))
306
307	5x	dots <- list(...)
308	5x	cex.lab <- make_par(dots, "cex.lab")
309	5x	col.lab <- make_par(dots, "col.lab")
310	5x	font.lab <- make_par(dots, "font.lab")
311	5x	cex.axis <- make_par(dots, "cex.axis")
312	5x	col.axis <- make_par(dots, "col.axis")
313	5x	font.axis <- make_par(dots, "font.axis")
314	5x	cex.main <- make_par(dots, "cex.main")
315	5x	font.main <- make_par(dots, "font.main")
316	5x	col.main <- make_par(dots, "col.main")
317
318	5x	years <- time(x, calendar = calendar)
319	5x	xlim <- xlim(x, calendar = calendar)
320	5x	ylim <- if (y_fixed) range(x, na.rm = TRUE) else NULL
321	5x	ylabs <- ylab %\|\|% labels(x) %\|\|% paste("Series", n_seq, sep = " ")
322	5x	for (j in n_seq) {
323		## Plot
324	30x	xj <- x[, j, , drop = FALSE]
325	30x	.plot_single(xj, calendar = calendar, panel = panel,
326	30x	xlim = xlim, ylim = ylim,
327	30x	main = NULL, sub = NULL, ann = FALSE, axes = FALSE,
328	30x	frame.plot = frame.plot,
329	30x	panel.first = panel.first, panel.last = panel.last, ...)
330
331		## Construct Axis
332	30x	xaxt <- make_par(dots, "xaxt")
333	30x	yaxt <- make_par(dots, "yaxt")
334	30x	do_x <- (j %% n_row == 0 \|\| j == n)
335	30x	y_side <- if (j %% 2 \|\| !y_flip) 2 else 4
336	30x	if (axes) {
337	30x	if (do_x && xaxt != "n") {
338	9x	year_axis(side = 1, format = TRUE, calendar = calendar,
339	9x	xpd = NA, cex.axis = cex.axis,
340	9x	col.axis = col.axis, font.axis = font.axis)
341		}
342	30x	if (yaxt != "n") {
343	30x	graphics::axis(side = y_side, xpd = NA, cex.axis = cex.axis,
344	30x	col.axis = col.axis, font.axis = font.axis, las = 1)
345		}
346		}
347
348		## Add annotation
349	30x	if (ann) {
350	30x	if (do_x) {
351	9x	cal_lab <- if (is.null(calendar)) expression(italic("rata die")) else format(calendar)
352	9x	xlab <- xlab %\|\|% cal_lab
353	9x	graphics::mtext(xlab, side = 1, line = 3, cex = cex.lab, col = col.lab,
354	9x	font = font.lab)
355		}
356	30x	graphics::mtext(ylabs[[j]], side = y_side, line = 3, cex = cex.lab,
357	30x	col = col.lab, font = font.lab)
358		}
359		}
360
361		## Add annotation
362	5x	if (ann) {
363	5x	graphics::par(mfcol = c(1, 1))
364	5x	graphics::mtext(main, side = 3, line = 3, cex = cex.main, font = font.main,
365	5x	col = col.main)
366		}
367
368	5x	invisible(x)
369		}
370
371		#' Compute x Limits
372		#'
373		#' Computes x limits for a time series according to a given calendar.
374		#' This ensures that the x axis is always in chronological order.
375		#' @param x A [`TimeSeries-class`] object.
376		#' @param calendar A [`TimeScale-class`] object.
377		#' @param finite A [`logical`] scalar: should non-finite elements be omitted?
378		#' @return A length-two [`numeric`] vector.
379		#' @keywords internal
380		#' @noRd
381		xlim <- function(x, calendar, finite = FALSE) {
382	9x	if (methods::is(x, "TimeSeries")) x <- time(x, calendar = NULL)
383	4x	if (methods::is(x, "TimeIntervals")) x <- c(start(x, calendar = NULL), end(x, calendar = NULL))
384	13x	x <- range(x, finite = finite)
385	2x	if (is.null(calendar)) return(x)
386	11x	as_year(x, calendar = calendar)
387		}
388
389		# Image ========================================================================
390		#' @export
391		#' @method image TimeSeries
392		image.TimeSeries <- function(x, calendar = get_calendar(), k = 1, ...) {
393		## Save calendar for further use, e.g. year_axis()
394	1x	assign("last_calendar", value = function(...) calendar, envir = the)
395
396		## Get data
397	1x	n <- seq_len(NCOL(x))
398	1x	samples <- labels(x) %\|\|% paste0("S1", n)
399	1x	years <- time(x, calendar = NULL)
400
401		## Graphical parameters
402	1x	cex.axis <- list(...)$cex.axis %\|\|% graphics::par("cex.axis")
403	1x	col.axis <- list(...)$col.axis %\|\|% graphics::par("col.axis")
404	1x	font.axis <- list(...)$font.axis %\|\|% graphics::par("font.axis")
405
406		## Save and restore
407	1x	mar <- graphics::par("mar")
408	1x	mar[2] <- inch2line(samples, cex = cex.axis) + 0.5
409	1x	old_par <- graphics::par(mar = mar)
410	1x	on.exit(graphics::par(old_par))
411
412		## Plot
413	1x	z <- x[, , k = k, drop = TRUE]
414	1x	graphics::image(x = years, y = n, z = z,
415	1x	xlab = format(calendar), ylab = "",
416	1x	xaxt = "n", yaxt = "n", ...)
417
418		## Construct axes
419	1x	at <- as_fixed(graphics::axTicks(side = 1))
420	1x	at <- pretty(at, calendar = calendar)
421	1x	lab <- format(at, label = FALSE, calendar = calendar)
422	1x	graphics::axis(side = 1, at = at, labels = lab)
423	1x	graphics::axis(side = 2, at = n, labels = samples,
424	1x	cex.axis = cex.axis, las = 1,
425	1x	col.axis = col.axis, font.axis = font.axis)
426
427	1x	invisible(x)
428		}
429
430		#' @export
431		#' @rdname image
432		#' @aliases image,TimeSeries-method
433		setMethod("image", c(x = "TimeSeries"), image.TimeSeries)

1		# GRAPH
2		#' @include AllGenerics.R
3		NULL
4
5		# S3 class as S4 ===============================================================
6		setClass("igraph")
7
8		# Create =======================================================================
9		#' @export
10		#' @rdname graph_create
11		#' @aliases graph_create,data.frame-method
12		setMethod(
13		f = "graph_create",
14		signature = c(object = "data.frame"),
15		definition = function(object, type = c("interval", "stratigraphy"),
16		direction = c("above", "below"),
17		verbose = getOption("aion.verbose"), ...) {
18		## Coerce to character matrix
19	2x	object[] <- lapply(X = object, FUN = as.character)
20	2x	object <- as.matrix(object)
21
22	2x	methods::callGeneric(object, type = type, direction = direction,
23	2x	verbose = verbose, ...)
24		}
25		)
26
27		#' @export
28		#' @rdname graph_create
29		#' @aliases graph_create,matrix-method
30		setMethod(
31		f = "graph_create",
32		signature = c(object = "matrix"),
33		definition = function(object, type = c("interval", "stratigraphy"),
34		direction = c("above", "below"),
35		verbose = getOption("aion.verbose"), ...) {
36		## Validation
37	6x	arkhe::assert_package("igraph")
38	6x	arkhe::assert_type(object, "character")
39	6x	arkhe::assert_dim(object, c(nrow(object), 2L))
40	6x	type <- match.arg(type, several.ok = FALSE)
41	6x	direction <- match.arg(direction, several.ok = FALSE)
42
43		## Remove singletons
44	6x	object <- arkhe::discard_rows(object, f = anyNA, verbose = verbose)
45
46		## Graph type
47	3x	if (identical(type, "interval")) directed <- FALSE
48	3x	if (identical(type, "stratigraphy")) directed <- TRUE
49
50		## Switch relations, if needed
51		## (does not matter if type == "interval")
52	6x	if (identical(direction, "below")) {
53	1x	object <- object[, c(2, 1)]
54		}
55
56		## Reorder
57	6x	object <- object[order(object[, 1], object[, 2]), ]
58
59		## Create graph
60	6x	graph <- igraph::graph_from_edgelist(el = object, directed = directed)
61
62		## Check
63	3x	if (identical(type, "interval")) assert_graph_chordal(graph)
64	3x	if (identical(type, "stratigraphy")) assert_graph_dag(graph)
65
66	6x	graph
67		}
68		)
69
70		#' @export
71		#' @rdname graph_create
72		#' @aliases graph_create,TimeIntervals-method
73		setMethod(
74		f = "graph_create",
75		signature = c(object = "TimeIntervals"),
76		definition = function(object, type = c("interval", "stratigraphy"),
77		verbose = getOption("aion.verbose"), ...) {
78		## Validation
79	2x	type <- match.arg(type, several.ok = FALSE)
80
81		## Detect relations
82	2x	rel <- switch(
83	2x	type,
84	2x	interval = rbind(overlaps(object), finishes(object), contains(object),
85	2x	starts(object), equals(object)),
86	2x	stratigraphy = rbind(preceded_by(object), met_by(object))
87		)
88
89	2x	methods::callGeneric(rel, type = type, direction = "above",
90	2x	verbose = verbose, ...)
91		}
92		)
93
94		# Prune ========================================================================
95		#' @export
96		#' @rdname graph_prune
97		#' @aliases graph_prune,igraph-method
98		setMethod(
99		f = "graph_prune",
100		signature = c(object = "igraph"),
101		definition = function(object, reduce = TRUE,
102		remove_multiple = TRUE, remove_loops = TRUE, ...) {
103
104		## Transitive reduction
105	1x	if (isTRUE(reduce) && isTRUE(igraph::is_dag(object))) {
106	1x	arkhe::assert_package("relations")
107
108	1x	edges <- as.matrix(object, matrix.type = c("edgelist"))
109	1x	endo <- relations::endorelation(
110		# domain = lapply(unique(as.character(edges)), sets::as.set),
111	1x	graph = as.data.frame(edges)
112		)
113	1x	red <- relations::transitive_reduction(endo)
114	1x	mat <- relations::relation_incidence(red)
115	1x	object <- igraph::graph_from_adjacency_matrix(mat, mode = "directed")
116		}
117
118		## Remove multiple edges and loop edges
119	1x	if (isTRUE(remove_multiple) \|\| isTRUE(remove_loops)) {
120	1x	object <- igraph::simplify(
121	1x	object,
122	1x	remove.multiple = remove_multiple,
123	1x	remove.loops = remove_loops
124		)
125		}
126
127	1x	object
128		}
129		)
130
131		# Check ========================================================================
132		## Check if DAG
133		assert_graph_dag <- function(x, must_fail = FALSE) {
134	5x	is_dag <- igraph::is_dag(x)
135	5x	if (!isTRUE(is_dag)) {
136	2x	msg <- tr_("This is not a stratigraphic graph!")
137	2x	do <- if (isTRUE(must_fail)) stop else warning
138	2x	do(msg, "\n", tr_("This is not a directed acyclic graph."), call. = FALSE)
139		}
140	4x	invisible(x)
141		}
142
143		## Check that there are no cycles with more than three nodes
144		assert_graph_chordal <- function(x, must_fail = FALSE) {
145	3x	is_chordal <- igraph::is_chordal(x)$chordal
146	3x	if (!isTRUE(is_chordal)) {
147	1x	msg <- tr_("This is not an interval graph!")
148	1x	do <- if (isTRUE(must_fail)) stop else warning
149	1x	do(msg, "\n", tr_("This is not a chordal graph."), call. = FALSE)
150		}
151	3x	invisible(x)
152		}

1		# TEMPORAL RELATIONS
2		#' @include AllGenerics.R
3		NULL
4
5		# Precede ======================================================================
6		#' @export
7		#' @rdname relations
8		#' @aliases precedes,TimeIntervals-method
9		setMethod(
10		f = "precedes",
11		signature = c(x = "TimeIntervals"),
12		definition = function(x, ...) {
13	1x	.relation(
14	1x	x = start(x, calendar = NULL),
15	1x	y = end(x, calendar = NULL),
16	1x	f = .precedes,
17	1x	labels = labels(x),
18		...
19		)
20		}
21		)
22
23		.precedes <- function(xmin, xmax, ymin, ymax) {
24	1x	xmin < ymin & xmax < ymin
25		}
26
27		#' @export
28		#' @rdname relations
29		#' @aliases preceded_by,TimeIntervals,missing-method
30		setMethod(
31		f = "preceded_by",
32		signature = c(x = "TimeIntervals"),
33		definition = function(x, ...) {
34	1x	.relation(
35	1x	x = start(x, calendar = NULL),
36	1x	y = end(x, calendar = NULL),
37	1x	f = .preceded_by,
38	1x	labels = labels(x),
39		...
40		)
41		}
42		)
43
44		.preceded_by <- function(xmin, xmax, ymin, ymax) {
45	1x	xmin > ymax
46		}
47
48		# Meet =========================================================================
49		#' @export
50		#' @rdname relations
51		#' @aliases meets,TimeIntervals-method
52		setMethod(
53		f = "meets",
54		signature = c(x = "TimeIntervals"),
55		definition = function(x, ...) {
56	!	.relation(
57	!	x = start(x, calendar = NULL),
58	!	y = end(x, calendar = NULL),
59	!	f = .meets,
60	!	labels = labels(x),
61		...
62		)
63		}
64		)
65
66		.meets <- function(xmin, xmax, ymin, ymax) {
67	!	xmin < ymin & xmax == ymin
68		}
69
70		#' @export
71		#' @rdname relations
72		#' @aliases met_by,TimeIntervals,missing-method
73		setMethod(
74		f = "met_by",
75		signature = c(x = "TimeIntervals"),
76		definition = function(x, ...) {
77	1x	.relation(
78	1x	x = start(x, calendar = NULL),
79	1x	y = end(x, calendar = NULL),
80	1x	f = .met_by,
81	1x	labels = labels(x),
82		...
83		)
84		}
85		)
86
87		.met_by <- function(xmin, xmax, ymin, ymax) {
88	1x	xmin == ymax
89		}
90
91		# Overlap ======================================================================
92		#' @export
93		#' @rdname relations
94		#' @aliases overlaps,TimeIntervals-method
95		setMethod(
96		f = "overlaps",
97		signature = c(x = "TimeIntervals"),
98		definition = function(x, ...) {
99	2x	.relation(
100	2x	x = start(x, calendar = NULL),
101	2x	y = end(x, calendar = NULL),
102	2x	f = .overlaps,
103	2x	labels = labels(x),
104		...
105		)
106		}
107		)
108
109		.overlaps <- function(xmin, xmax, ymin, ymax) {
110	2x	xmin < ymin & xmax > ymin & xmax < ymax
111		}
112
113		#' @export
114		#' @rdname relations
115		#' @aliases overlapped_by,TimeIntervals,missing-method
116		setMethod(
117		f = "overlapped_by",
118		signature = c(x = "TimeIntervals"),
119		definition = function(x, ...) {
120	!	.relation(
121	!	x = start(x, calendar = NULL),
122	!	y = end(x, calendar = NULL),
123	!	f = .overlapped_by,
124	!	labels = labels(x),
125		...
126		)
127		}
128		)
129
130		.overlapped_by <- function(xmin, xmax, ymin, ymax) {
131	!	xmin > ymin & xmin < ymax & xmax > ymax
132		}
133
134		# Finish =======================================================================
135		#' @export
136		#' @rdname relations
137		#' @aliases finishes,TimeIntervals,missing-method
138		setMethod(
139		f = "finishes",
140		signature = c(x = "TimeIntervals"),
141		definition = function(x, ...) {
142	1x	.relation(
143	1x	x = start(x, calendar = NULL),
144	1x	y = end(x, calendar = NULL),
145	1x	f = .finishes,
146	1x	labels = labels(x),
147		...
148		)
149		}
150		)
151
152		.finishes <- function(xmin, xmax, ymin, ymax) {
153	1x	xmin > ymin & xmax == ymax
154		}
155
156		#' @export
157		#' @rdname relations
158		#' @aliases finished_by,TimeIntervals-method
159		setMethod(
160		f = "finished_by",
161		signature = c(x = "TimeIntervals"),
162		definition = function(x, ...) {
163	!	.relation(
164	!	x = start(x, calendar = NULL),
165	!	y = end(x, calendar = NULL),
166	!	f = .finished_by,
167	!	labels = labels(x),
168		...
169		)
170		}
171		)
172
173		.finished_by <- function(xmin, xmax, ymin, ymax) {
174	!	xmin < ymin & xmax == ymax
175		}
176
177		# Contain ======================================================================
178		#' @export
179		#' @rdname relations
180		#' @aliases contains,TimeIntervals-method
181		setMethod(
182		f = "contains",
183		signature = c(x = "TimeIntervals"),
184		definition = function(x, ...) {
185	2x	.relation(
186	2x	x = start(x, calendar = NULL),
187	2x	y = end(x, calendar = NULL),
188	2x	f = .contains,
189	2x	labels = labels(x),
190		...
191		)
192		}
193		)
194
195		.contains <- function(xmin, xmax, ymin, ymax) {
196	2x	xmin < ymin & xmax > ymax
197		}
198
199		#' @export
200		#' @rdname relations
201		#' @aliases during,TimeIntervals,missing-method
202		setMethod(
203		f = "during",
204		signature = c(x = "TimeIntervals"),
205		definition = function(x, ...) {
206	!	.relation(
207	!	x = start(x, calendar = NULL),
208	!	y = end(x, calendar = NULL),
209	!	f = .during,
210	!	labels = labels(x),
211		...
212		)
213		}
214		)
215
216		.during <- function(xmin, xmax, ymin, ymax) {
217	!	xmin > ymin & xmax < ymax
218		}
219
220		# Start ========================================================================
221		#' @export
222		#' @rdname relations
223		#' @aliases starts,TimeIntervals,missing-method
224		setMethod(
225		f = "starts",
226		signature = c(x = "TimeIntervals"),
227		definition = function(x, ...) {
228	1x	.relation(
229	1x	x = start(x, calendar = NULL),
230	1x	y = end(x, calendar = NULL),
231	1x	f = .starts,
232	1x	labels = labels(x),
233		...
234		)
235		}
236		)
237
238		.starts <- function(xmin, xmax, ymin, ymax) {
239	1x	xmin == ymin & xmax < ymax
240		}
241
242		#' @export
243		#' @rdname relations
244		#' @aliases started_by,TimeIntervals,missing-method
245		setMethod(
246		f = "started_by",
247		signature = c(x = "TimeIntervals"),
248		definition = function(x, ...) {
249	!	.relation(
250	!	x = start(x, calendar = NULL),
251	!	y = end(x, calendar = NULL),
252	!	f = .started_by,
253	!	labels = labels(x),
254		...
255		)
256		}
257		)
258
259		.started_by <- function(xmin, xmax, ymin, ymax) {
260	!	xmin == ymin & xmax > ymax
261		}
262
263		# Equal ========================================================================
264		#' @export
265		#' @rdname relations
266		#' @aliases equals,TimeIntervals,missing-method
267		setMethod(
268		f = "equals",
269		signature = c(x = "TimeIntervals"),
270		definition = function(x, ...) {
271	1x	.relation(
272	1x	x = start(x, calendar = NULL),
273	1x	y = end(x, calendar = NULL),
274	1x	f = .equals,
275	1x	labels = labels(x),
276		...
277		)
278		}
279		)
280
281		.equals <- function(xmin, xmax, ymin, ymax) {
282	1x	xmin == ymin & xmax == ymax
283		}
284
285		# Helpers ======================================================================
286		.relation <- function(x, y, f, labels = NULL, use_names = TRUE) {
287	10x	n <- length(x)
288	10x	arkhe::assert_function(f)
289	10x	arkhe::assert_length(y, n)
290	10x	assert_ordered(x, y)
291
292	10x	labels <- labels %\|\|% names(x) %\|\|% names(y)
293	!	if (!isTRUE(use_names)) labels <- seq_along(labels)
294
295	10x	el <- seq_len(n)
296	10x	comb <- cbind(
297	10x	utils::combn(el, m = 2, simplify = TRUE),
298	10x	utils::combn(rev(el), m = 2, simplify = TRUE)
299		)
300	10x	xmin <- x[comb[1, ]]
301	10x	xmax <- y[comb[1, ]]
302	10x	ymin <- x[comb[2, ]]
303	10x	ymax <- y[comb[2, ]]
304
305	10x	mtx <- matrix(
306	10x	data = c(labels[comb[1, ]], labels[comb[2, ]]),
307	10x	ncol = 2
308		)
309
310	10x	rel <- f(xmin, xmax, ymin, ymax)
311	10x	mtx <- mtx[rel, , drop = FALSE]
312	10x	mtx <- mtx[order(mtx[, 1], mtx[, 2]), ]
313	10x	mtx
314		}

1		# HELPERS
2
3		## https://michaelchirico.github.io/potools/articles/developers.html
4		tr_ <- function(...) {
5	318x	enc2utf8(gettext(paste0(...), domain = "R-aion"))
6		}
7
8		make_par <- function(params, x, n = 1) {
9	321x	p <- params[[x]] %\|\|% graphics::par()[[x]]
10	12x	if (length(p) == 1 && n > 1) p <- rep(p, length.out = n)
11	321x	p
12		}
13
14		fix_dimnames <- function(x, dim2 = "S", dim3 = "V") {
15	3x	if (is.null(dimnames(x)[[2L]])) {
16	!	dimnames(x)[[2L]] <- paste0(dim2, seq_len(dim(x)[[2L]]))
17		}
18	3x	if (is.null(dimnames(x)[[3L]])) {
19	1x	dimnames(x)[[3L]] <- paste0(dim3, seq_len(dim(x)[[3L]]))
20		}
21	3x	x
22		}
23
24		#' Plotting Dimensions of Character Strings
25		#'
26		#' Convert string length in inch to number of (margin) lines.
27		#' @param x A [`character`] vector of string whose length is to be calculated.
28		#' @param ... Further parameter to be passed to [graphics::strwidth()]`, such as
29		#' `cex`.
30		#' @return
31		#' A [`numeric`] vector (maximum string width in units of margin lines).
32		#' @note For internal use only.
33		#' @family graphic tools
34		#' @keywords internal
35		#' @noRd
36		inch2line <- function(x, ...) {
37	1x	(max(graphics::strwidth(x, units = "inch", ...)) /
38	1x	graphics::par("cin")[2] + graphics::par("mgp")[2]) * graphics::par("cex")
39		}

1		# TIME SCALE
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname calendar
7		#' @aliases calendar,character-method
8		setMethod(
9		f = "calendar",
10		signature = "character",
11		definition = function(object) {
12		switch (
13	50x	tolower(object),
14	7x	bp = BP(),
15	!	b2k = b2k(),
16	!	bc = BC(),
17	12x	bce = BCE(),
18	2x	ad = AD(),
19	27x	ce = CE(),
20	1x	julian = J(),
21	1x	stop(sprintf(tr_("Unknown calendar: %s"), object), call. = FALSE)
22		)
23		}
24		)
25
26		#' @export
27		#' @rdname gregorian
28		BP <- function(...) {
29	19x	.GregorianCalendar(
30	19x	label = tr_("BP"),
31	19x	name = tr_("Before Present"),
32	19x	epoch = 1950,
33	19x	direction = -1L
34		)
35		}
36
37		#' @export
38		#' @rdname gregorian
39		b2k <- function(...) {
40	5x	.GregorianCalendar(
41	5x	label = tr_("b2k"),
42	5x	name = tr_("Before 2000"),
43	5x	epoch = 2000,
44	5x	direction = -1L
45		)
46		}
47
48		#' @export
49		#' @rdname gregorian
50		BC <- function(...) {
51	2x	.GregorianCalendar(
52	2x	label = tr_("BC"),
53	2x	name = tr_("Before Christ"),
54	2x	direction = -1L
55		)
56		}
57
58		#' @export
59		#' @rdname gregorian
60		BCE <- function(...) {
61	21x	.GregorianCalendar(
62	21x	label = tr_("BCE"),
63	21x	name = tr_("Before Common Era"),
64	21x	direction = -1L
65		)
66		}
67
68		#' @export
69		#' @rdname gregorian
70		AD <- function(...) {
71	19x	.GregorianCalendar(
72	19x	label = tr_("AD"),
73	19x	name = tr_("Anno Domini")
74		)
75		}
76
77		#' @export
78		#' @rdname gregorian
79		CE <- function(...) {
80	78x	.GregorianCalendar(
81	78x	label = tr_("CE"),
82	78x	name = tr_("Common Era")
83		)
84		}
85
86		#' @export
87		#' @rdname julian
88		J <- function(...) {
89	15x	.JulianCalendar(
90	15x	label = "",
91	15x	name = ""
92		)
93		}
94
95		# Default calendar =============================================================
96		the <- new.env(parent = emptyenv())
97		the$default_calendar <- function(...) calendar("CE")
98		the$last_calendar <- function(...) return(NULL)
99
100		#' @export
101		#' @rdname get_calendar
102		get_calendar <- function(which = c("default", "current")) {
103	32x	which <- match.arg(which, several.ok = FALSE)
104	32x	which_calendar <- switch(
105	32x	which,
106	32x	default = "default_calendar",
107	32x	current = "last_calendar"
108		)
109
110	32x	if (!exists(which_calendar, envir = the)) {
111	!	stop(tr_("Unspecified calendar."), call. = FALSE)
112		}
113
114	32x	cal <- get(which_calendar, envir = the)
115	32x	if (!is.null(cal()) && !is_calendar(cal())) {
116	!	stop(tr_("Invalid calendar."), call. = FALSE)
117		}
118	32x	return(cal())
119		}
120
121		#' @export
122		#' @rdname get_calendar
123		set_calendar <- function(x, which = c("default", "current")) {
124	1x	if (missing(x)) x <- "CE"
125	2x	which <- match.arg(which, several.ok = FALSE)
126	2x	which_calendar <- switch(
127	2x	which,
128	2x	default = "default_calendar",
129	2x	current = "last_calendar"
130		)
131
132	2x	cal <- function(...) calendar(x)
133	2x	assign(which_calendar, value = cal, envir = the)
134	2x	invisible(cal())
135		}
136
137		# Predicates ===================================================================
138		#' Is an Object a Calendar?
139		#'
140		#' Test inheritance relationships between an object and a calendar class.
141		#' @param object Any \R object.
142		#' @return
143		#' A [`logical`] scalar.
144		#' @author N. Frerebeau
145		#' @docType methods
146		#' @family calendar tools
147		#' @export
148		is_calendar <- function(object) {
149	30x	methods::is(object, "TimeScale")
150		}
151
152		#' @export
153		#' @rdname is_calendar
154		is_gregorian <- function(object) {
155	21x	methods::is(object, "GregorianCalendar")
156		}
157
158		#' @export
159		#' @rdname is_calendar
160		is_julian <- function(object) {
161	6x	methods::is(object, "JulianCalendar")
162		}
163
164		# Mutators =====================================================================
165		## Getters ---------------------------------------------------------------------
166		#' @export
167		#' @rdname calendar_get
168		#' @aliases calendar_label,TimeScale-method
169		setMethod(
170		f = "calendar_label",
171		signature = "TimeScale",
172	26x	definition = function(object) object@label
173		)
174
175		#' @export
176		#' @rdname calendar_get
177		#' @aliases calendar_name,TimeScale-method
178		setMethod(
179		f = "calendar_name",
180		signature = "TimeScale",
181	2x	definition = function(object) object@name
182		)
183
184		#' @export
185		#' @rdname calendar_get
186		#' @aliases calendar_unit,TimeScale-method
187		setMethod(
188		f = "calendar_unit",
189		signature = "TimeScale",
190		definition = function(object) {
191	15x	if (is_gregorian(object)) return(tr_("Gregorian years"))
192	4x	if (is_julian(object)) return(tr_("Julian years"))
193	!	return(tr_("Undefined"))
194		}
195		)
196
197		#' @export
198		#' @rdname calendar_get
199		#' @aliases calendar_epoch,TimeScale-method
200		setMethod(
201		f = "calendar_epoch",
202		signature = "TimeScale",
203	508x	definition = function(object) object@epoch
204		)
205
206		#' @export
207		#' @rdname calendar_get
208		#' @aliases calendar_fixed,TimeScale-method
209		setMethod(
210		f = "calendar_fixed",
211		signature = "TimeScale",
212	561x	definition = function(object) object@fixed
213		)
214
215		#' @export
216		#' @rdname calendar_get
217		#' @aliases calendar_direction,TimeScale-method
218		setMethod(
219		f = "calendar_direction",
220		signature = "TimeScale",
221	523x	definition = function(object) sign(object@direction)
222		)
223
224		#' @export
225		#' @rdname calendar_get
226		#' @aliases calendar_direction,NULL-method
227		setMethod(
228		f = "calendar_direction",
229		signature = "NULL",
230	1x	definition = function(object) 1L
231		)
232
233		#' @export
234		#' @rdname calendar_get
235		#' @aliases calendar_year,TimeScale-method
236		setMethod(
237		f = "calendar_year",
238		signature = "TimeScale",
239	2x	definition = function(object) object@year
240		)

1		# AXIS
2
3		# Pretty =======================================================================
4		#' @export
5		#' @method pretty RataDie
6		pretty.RataDie <- function(x, calendar = get_calendar(), ...) {
7	!	if (is.null(calendar)) return(pretty(as.numeric(x), ...))
8
9	17x	x <- as_year(x, calendar = calendar, decimal = FALSE)
10	17x	x <- pretty(x, ...)
11	2x	if (methods::is(calendar, "JulianCalendar")) x[x == 0] <- 1
12	17x	fixed(year = x, calendar = calendar)
13		}
14
15		#' @export
16		#' @rdname pretty
17		setMethod("pretty", "RataDie", pretty.RataDie)
18
19		# Axis =========================================================================
20		#' @export
21		#' @rdname year_axis
22		year_axis <- function(side, at = NULL, format = c("a", "ka", "Ma", "Ga"),
23		labels = TRUE, calendar = get_calendar("current"),
24		current_calendar = get_calendar("current"),
25		...) {
26	19x	no_at <- missing(at) \|\| is.null(at) \|\| !is.numeric(at)
27	19x	if (no_at) at <- graphics::axTicks(side = side)
28
29	19x	if (!is.logical(labels)) {
30	!	labels <- labels[keep]
31	19x	} else if (isTRUE(labels)) {
32		## If last_calendar is NULL, then the last plot was expressed in rata die
33	19x	if (is.null(current_calendar)) {
34	3x	at <- as_fixed(at)
35		} else {
36	2x	if (methods::is(calendar, "JulianCalendar")) at[at == 0] <- 1
37	16x	at <- fixed(at, calendar = current_calendar)
38		}
39	19x	if (!is.null(calendar)) {
40	16x	at <- pretty(at, calendar = calendar)
41	16x	labels <- format(at, prefix = format, label = FALSE, calendar = calendar)
42	16x	if (!is.null(current_calendar)) at <- as_year(at, calendar = current_calendar)
43		}
44	!	} else if (isFALSE(labels)) {
45	!	labels <- rep("", length(at))
46		}
47
48	19x	graphics::axis(side, at = as.numeric(at), labels = labels, ...)
49		}

1		# TIME
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @method start TimeSeries
7		start.TimeSeries <- function(x, calendar = NULL, ...) {
8	11x	z <- min(x@.Time)
9	7x	if (is.null(calendar)) return(z)
10	4x	as_year(z, calendar = calendar, decimal = TRUE)
11		}
12
13		#' @export
14		#' @rdname start
15		#' @aliases start,TimeSeries-method
16		setMethod("start", "TimeSeries", start.TimeSeries)
17
18		#' @export
19		#' @method start TimeIntervals
20		start.TimeIntervals <- function(x, calendar = NULL, ...) {
21	32x	z <- x@.Start
22	19x	if (is.null(calendar)) return(z)
23	13x	as_year(z, calendar = calendar, decimal = TRUE)
24		}
25
26		#' @export
27		#' @rdname start
28		#' @aliases start,TimeIntervals-method
29		setMethod("start", "TimeIntervals", start.TimeIntervals)
30
31		#' @export
32		#' @method end TimeSeries
33		end.TimeSeries <- function(x, calendar = NULL, ...) {
34	11x	z <- max(x@.Time)
35	7x	if (is.null(calendar)) return(z)
36	4x	as_year(z, calendar = calendar, decimal = TRUE)
37		}
38
39		#' @export
40		#' @rdname start
41		#' @aliases end,TimeSeries-method
42		setMethod("end", "TimeSeries", end.TimeSeries)
43
44		#' @export
45		#' @method end TimeIntervals
46		end.TimeIntervals <- function(x, calendar = NULL, ...) {
47	32x	z <- x@.End
48	19x	if (is.null(calendar)) return(z)
49	13x	as_year(z, calendar = calendar, decimal = TRUE)
50		}
51
52		#' @export
53		#' @rdname start
54		#' @aliases end,TimeIntervals-method
55		setMethod("end", "TimeIntervals", end.TimeIntervals)
56
57		#' @export
58		#' @method time TimeSeries
59		time.TimeSeries <- function(x, calendar = NULL, ...) {
60	60x	z <- x@.Time
61	25x	if (is.null(calendar)) return(z)
62	35x	as_year(z, calendar = calendar, decimal = TRUE)
63		}
64
65		#' @export
66		#' @rdname time
67		#' @aliases time,TimeSeries-method
68		setMethod("time", "TimeSeries", time.TimeSeries)
69
70		#' @export
71		#' @method frequency TimeSeries
72		frequency.TimeSeries <- function(x, ...) {
73	1x	mean(abs(1 / diff(time(x))))
74		}
75
76		#' @export
77		#' @rdname time
78		#' @aliases frequency,TimeSeries-method
79		setMethod("frequency", "TimeSeries", frequency.TimeSeries)

1		# TIME INTERVALS
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname intervals
7		#' @aliases intervals,RataDie,RataDie,missing-method
8		setMethod(
9		f = "intervals",
10		signature = c(start = "RataDie", end = "RataDie", calendar = "missing"),
11		definition = function(start, end, names = NULL) {
12	9x	n <- length(start)
13	9x	arkhe::assert_length(end, n)
14
15		## Set the names
16	9x	if (is.null(names)) {
17	7x	names <- paste0("I", seq_len(n))
18		} else {
19	2x	names <- as.character(names)
20		}
21	9x	arkhe::assert_length(names, n)
22
23	9x	.TimeIntervals(.Id = names, .Start = start, .End = end)
24		}
25		)
26
27		#' @export
28		#' @rdname intervals
29		#' @aliases intervals,numeric,numeric,TimeScale-method
30		setMethod(
31		f = "intervals",
32		signature = c(start = "numeric", end = "numeric", calendar = "TimeScale"),
33		definition = function(start, end, calendar, scale = 1, names = NULL) {
34		## Start
35	8x	if (methods::is(start, "RataDie")) {
36	1x	msg <- "%s is already expressed in rata die: %s is ignored."
37	1x	warning(sprintf(msg, sQuote("start"), sQuote("calendar")), call. = FALSE)
38		} else {
39	7x	start <- fixed(start, calendar = calendar, scale = scale)
40		}
41
42		## End
43	8x	if (methods::is(end, "RataDie")) {
44	1x	msg <- tr_("%s is already expressed in rata die: %s is ignored.")
45	1x	warning(sprintf(msg, sQuote("end"), sQuote("calendar")), call. = FALSE)
46		} else {
47	7x	end <- fixed(end, calendar = calendar, scale = scale)
48		}
49
50	8x	names <- names %\|\|% names(start) %\|\|% names(end)
51	8x	methods::callGeneric(start = start, end = end, names = names)
52		}
53		)

1		# JULINA CALENDAR
2		#' @include AllGenerics.R
3		NULL
4
5		# Fixed from Julian ============================================================
6		#' @export
7		#' @rdname fixed
8		#' @aliases fixed,numeric,missing,missing,JulianCalendar-method
9		setMethod(
10		f = "fixed",
11		signature = c(year = "numeric", month = "missing", day = "missing", calendar = "JulianCalendar"),
12		definition = function(year, calendar, scale = 1) {
13		## Rescale to years (if not already)
14	6x	year <- year * scale
15
16	6x	rd <- fixed(year, 01, 01, calendar = calendar)
17
18	5x	is_leap <- which(is_julian_leap_year(year))
19	5x	rd[is_leap] <- ceiling(rd[is_leap]) # WHY ???
20	5x	rd
21		}
22		)
23
24		#' @export
25		#' @rdname fixed
26		#' @aliases fixed,numeric,numeric,numeric,JulianCalendar-method
27		setMethod(
28		f = "fixed",
29		signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "JulianCalendar"),
30		definition = function(year, month, day, calendar) {
31		## Validation
32	36x	if (any(year == 0)) {
33	1x	stop(tr_("There is no year zero in the Julian calendar."), call. = FALSE)
34		}
35
36		## Correct for 28- or 29-day Feb
37	35x	correction <- rep(-2, length(year))
38	35x	correction[which(is_julian_leap_year(year))] <- -1
39	35x	correction[month <= 2] <- 0
40
41		## There is no year 0 on the Julian calendar
42	35x	year[year < 0] <- year[year < 0] + 1
43
44	35x	rd <- calendar_fixed(calendar) - 1 + # Days before start of calendar
45	35x	365 * (year - 1) + # Ordinary days since epoch
46	35x	(year - 1) %/% 4 + # Leap days since epoch
47	35x	(367 * month - 362) %/% 12 + # Days in prior months this year assuming 30-day Feb
48	35x	correction + # Correct for 28- or 29-day Feb
49	35x	day # Days so far this month.
50
51		## Fix infinite values
52	35x	rd[is.infinite(year)] <- year[is.infinite(year)]
53
54	35x	.RataDie(rd)
55		}
56		)
57
58		# Julian from fixed ============================================================
59		#' @export
60		#' @rdname as_year
61		#' @aliases as_year,numeric,JulianCalendar-method
62		setMethod(
63		f = "as_year",
64		signature = c(object = "numeric", calendar = "JulianCalendar"),
65		definition = function(object, calendar, decimal = FALSE, ...) {
66	21x	d0 <- object - calendar_fixed(calendar)
67	21x	year <- (4 * d0 + 1464) %/% 1461
68
69		## There is no year 0 on the Julian calendar
70	21x	year[year <= 0] <- year[year <= 0] - 1
71
72	21x	if (isTRUE(decimal)) {
73		## Year length in days
74	8x	start <- fixed(year, 01, 01, calendar = calendar)
75	8x	end <- fixed(year, 12, 31, calendar = calendar)
76	8x	total <- end - start + 1
77
78		## Elapsed time
79	8x	sofar <- object - start
80
81	8x	year <- year + sofar / total
82		}
83
84		## Fix infinite values
85	21x	year[is.infinite(object)] <- object[is.infinite(object)]
86
87	21x	unclass(year)
88		}
89		)
90
91		#' @export
92		#' @rdname as_date
93		#' @aliases as_date,numeric,JulianCalendar-method
94		setMethod(
95		f = "as_date",
96		signature = c(object = "numeric", calendar = "JulianCalendar"),
97		definition = function(object, calendar) {
98	3x	year <- as_year(object, calendar = calendar, decimal = FALSE)
99	3x	prior_days <- object - fixed(year, 01, 01, calendar = calendar)
100
101	3x	correction <- rep(2, length(object))
102	3x	correction[object < fixed(year, 03, 01, calendar = calendar)] <- 0
103	3x	correction[is_julian_leap_year(year)] <- 1
104
105	3x	month <- (12 * (prior_days + correction) + 373) %/% 367
106	3x	day <- object - fixed(year, month, 01, calendar = calendar) + 1
107
108	3x	data.frame(
109	3x	year = unclass(year),
110	3x	month = unclass(month),
111	3x	day = unclass(day)
112		)
113		}
114		)
115
116		# Era ==========================================================================
117		#' @export
118		#' @rdname fixed_julian
119		fixed_from_julian <- function(year, month, day) {
120	!	if (missing(month) \|\| missing(day)) fixed(year, calendar = J())
121	1x	else fixed(year, month, day, calendar = J())
122		}
123
124		#' @export
125		#' @rdname fixed_julian
126		fixed_to_julian <- function(object) {
127	1x	as_year(object, calendar = J())
128		}

1		# OPERATORS
2		#' @include AllGenerics.R
3		NULL
4
5		# "+", "-", "*", "^", "%%", "%/%", "/"
6		#' @export
7		#' @rdname arithmetic
8		#' @aliases Arith,RataDie,RataDie-method
9		setMethod(
10		f = "Arith",
11		signature = c(e1 = "RataDie", e2 = "RataDie"),
12		definition = function(e1, e2) {
13	400x	z <- methods::callGeneric(e1@.Data, e2@.Data)
14		switch(
15	400x	.Generic[[1]],
16	2x	`+` = return(.RataDie(z)),
17	267x	`-` = return(.RataDie(z)),
18	131x	return(z)
19		)
20		}
21		)
22
23		#' @export
24		#' @rdname arithmetic
25		#' @aliases Arith,numeric,RataDie-method
26		setMethod(
27		f = "Arith",
28		signature = c(e1 = "numeric", e2 = "RataDie"),
29		definition = function(e1, e2) {
30	54x	z <- methods::callGeneric(e1, e2@.Data)
31		switch(
32	54x	.Generic[[1]],
33	1x	`+` = return(.RataDie(z)),
34	19x	`-` = return(.RataDie(z)),
35	33x	`*` = return(.RataDie(z)),
36	1x	return(z)
37		)
38		}
39		)
40
41		#' @export
42		#' @rdname arithmetic
43		#' @aliases Arith,RataDie,numeric-method
44		setMethod(
45		f = "Arith",
46		signature = c(e1 = "RataDie", e2 = "numeric"),
47		definition = function(e1, e2) {
48	623x	z <- methods::callGeneric(e1@.Data, e2)
49		switch(
50	623x	.Generic[[1]],
51	188x	`+` = return(.RataDie(z)),
52	148x	`-` = return(.RataDie(z)),
53	1x	`*` = return(.RataDie(z)),
54	1x	`/` = return(.RataDie(z)),
55	285x	return(z)
56		)
57		}
58		)

1		# FORMAT
2
3		# Format =======================================================================
4		#' @export
5		#' @method format TimeIntervals
6		format.TimeIntervals <- function(x, calendar = get_calendar(), ...) {
7	1x	debut <- start(x, calendar = calendar)
8	1x	fin <- end(x, calendar = calendar)
9
10	1x	msg <- sprintf("[%g, %g]", debut, fin)
11	1x	trimws(msg)
12		}
13
14		#' @export
15		#' @rdname format
16		setMethod("format", "TimeIntervals", format.TimeIntervals)
17
18		#' @export
19		#' @method format TimeScale
20		format.TimeScale <- function(x, ...) {
21	19x	msg <- sprintf("%s %s", calendar_unit(x), calendar_label(x))
22	19x	trimws(msg)
23		}
24
25		#' @export
26		#' @rdname format
27		setMethod("format", "TimeScale", format.TimeScale)
28
29		#' @export
30		#' @method format RataDie
31		format.RataDie <- function(x, prefix = c("a", "ka", "Ma", "Ga"), label = TRUE,
32		calendar = get_calendar(), ...) {
33	!	if (is.null(calendar)) return(format(as.numeric(x)))
34	22x	y <- as_year(x, calendar = calendar)
35
36		## Scale
37	22x	if (isTRUE(prefix)) {
38	12x	power <- 10^floor(log10(abs(mean(y, na.rm = TRUE))))
39	12x	if (prefix < 10^4) prefix <- "a"
40	1x	if (power >= 10^4 && power < 10^6) prefix <- "ka"
41	!	if (power >= 10^6 && power < 10^9) prefix <- "Ma"
42	!	if (power >= 10^9) prefix <- "Ga"
43		}
44	22x	prefix <- match.arg(prefix, several.ok = FALSE)
45	22x	power <- switch (prefix, ka = 10^3, Ma = 10^6, Ga = 10^9, 1)
46
47	22x	prefix <- if (power > 1) sprintf(" %s", prefix) else ""
48	22x	label <- if (isTRUE(label)) sprintf(" %s", calendar_label(calendar)) else ""
49	22x	trimws(sprintf("%g%s%s", y / power, prefix, label))
50		}
51
52		#' @export
53		#' @rdname format
54		setMethod("format", "RataDie", format.RataDie)

1		# OVERLAP
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname overlap
7		#' @aliases overlap,TimeIntervals-method
8		setMethod(
9		f = "overlap",
10		signature = "TimeIntervals",
11		definition = function(x, calendar = NULL, aggregate = TRUE) {
12	4x	labels <- labels(x)
13	4x	lower <- start(x, calendar = calendar) * calendar_direction(calendar)
14	4x	upper <- end(x, calendar = calendar) * calendar_direction(calendar)
15	4x	m <- length(x)
16
17		## Compute overlap
18	4x	index <- utils::combn(
19	4x	x = seq_len(m),
20	4x	m = 2,
21	4x	FUN = function(x) max(0, min(upper[x]) - max(lower[x]) + 1)
22		)
23
24		## Matrix of results
25	4x	mtx <- matrix(data = upper - lower, nrow = m, ncol = m, dimnames = list(labels, labels))
26	4x	mtx[lower.tri(mtx, diag = FALSE)] <- index
27	4x	mtx <- t(mtx)
28	4x	mtx[lower.tri(mtx, diag = FALSE)] <- index
29
30		## Aggregate in case of disjoint intervals referring to the same event
31	4x	if (isTRUE(aggregate)) {
32	4x	mtx <- t(rowsum(mtx, group = labels, reorder = FALSE))
33	4x	mtx <- rowsum(mtx, group = labels, reorder = FALSE)
34		}
35
36	4x	mtx
37		}
38		)

1		# COERCION
2		#' @include AllGenerics.R
3		NULL
4
5		# To RataDie ===================================================================
6		#' @export
7		#' @rdname as_fixed
8		#' @aliases as_fixed,numeric-method
9		setMethod(
10		f = "as_fixed",
11		signature = "numeric",
12	5x	definition = function(from) .RataDie(from)
13		)
14
15		# To data.frame ================================================================
16		#' @export
17		#' @method as.data.frame TimeSeries
18		as.data.frame.TimeSeries <- function(x, ..., calendar = NULL) {
19		## Fix dimnames (if needed)
20	1x	x <- fix_dimnames(x)
21		## Build a long data frame
22	1x	data.frame(
23	1x	time = time(x, calendar = calendar)[as.vector(slice.index(x, MARGIN = 1L))],
24	1x	series = dimnames(x)[[2L]][as.vector(slice.index(x, MARGIN = 2L))],
25	1x	variable = dimnames(x)[[3L]][as.vector(slice.index(x, MARGIN = 3L))],
26	1x	value = as.vector(x)
27		)
28		}
29
30		#' @export
31		#' @describeIn as.data.frame Returns a long [`data.frame`] with the following columns:
32		#' \describe{
33		#' \item{`time`}{The sampling times. If `calendar` is not `NULL`, it is
34		#' expressed in decimal years; otherwise, it is expressed in rata die.}
35		#' \item{`series`}{The name of the time series.}
36		#' \item{`variable`}{The name of the variables.}
37		#' \item{`value`}{The observed value.}
38		#' }
39		#' @aliases as.data.frame,TimeSeries-method
40		setMethod("as.data.frame", "TimeSeries", as.data.frame.TimeSeries)
41
42		#' @export
43		#' @method as.data.frame TimeIntervals
44		as.data.frame.TimeIntervals <- function(x, ..., calendar = NULL) {
45		## Build a data frame
46	4x	data.frame(
47	4x	label = labels(x),
48	4x	start = start(x, calendar = calendar),
49	4x	end = end(x, calendar = calendar)
50		)
51		}
52
53		#' @export
54		#' @describeIn as.data.frame Returns a [`data.frame`] with the following columns:
55		#' \describe{
56		#' \item{`label`}{The name of the intervals.}
57		#' \item{`start`}{The start time of the intervals. If `calendar` is not
58		#' `NULL`, it is expressed in decimal years; otherwise, it is expressed in
59		#' rata die.}
60		#' \item{`end`}{The end time of the intervals. If `calendar` is not `NULL`, it
61		#' is expressed in decimal years; otherwise, it is expressed in rata die.}
62		#' }
63		#' @aliases as.data.frame,TimeIntervals-method
64		setMethod("as.data.frame", "TimeIntervals", as.data.frame.TimeIntervals)
65
66		# To array =====================================================================
67		#' @export
68		#' @method as.array TimeSeries
69		as.array.TimeSeries <- function(x, ...) {
70	!	methods::as(x, "array")
71		}
72
73		#' @export
74		#' @rdname as.array
75		#' @aliases as.array,TimeSeries-method
76		setMethod("as.array", "TimeSeries", as.array.TimeSeries)

1		# YEAR
2		#' @include AllGenerics.R
3		NULL
4
5		# Decimal years ================================================================
6		#' @export
7		#' @rdname as_decimal
8		#' @aliases as_decimal,numeric,numeric,numeric,GregorianCalendar-method
9		setMethod(
10		f = "as_decimal",
11		signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "GregorianCalendar"),
12		definition = function(year, month, day, calendar) {
13		## Shift origin
14	3x	year <- (year - calendar_epoch(calendar)) * calendar_direction(calendar)
15
16	3x	.as_decimal(year, month, day, calendar)
17		}
18		)
19
20		#' @export
21		#' @rdname as_decimal
22		#' @aliases as_decimal,numeric,numeric,numeric,JulianCalendar-method
23		setMethod(
24		f = "as_decimal",
25		signature = c(year = "numeric", month = "numeric", day = "numeric", calendar = "JulianCalendar"),
26		definition = function(year, month, day, calendar) {
27	1x	.as_decimal(year, month, day, calendar)
28		}
29		)
30
31		.as_decimal <- function(year, month, day, calendar) {
32		## Year length in days
33	4x	start <- fixed(year, 01, 01, calendar = calendar)
34	4x	end <- fixed(year, 12, 31, calendar = calendar)
35	4x	total <- end - start + 1
36
37		## Elapsed time
38	4x	date <- fixed(year, month, day, calendar = calendar)
39	4x	sofar <- date - start
40
41	4x	unclass(year + sofar / total)
42		}
43
44		# Leap year ====================================================================
45		is_julian_leap_year <- function(year) {
46	43x	year <- floor(year) # Drop decimal part (if any)
47	43x	leap <- year %% 4 == 3
48	43x	leap[year > 0] <- year[year > 0] %% 4 == 0
49	43x	leap
50		}
51
52		is_gregorian_leap_year <- function(year) {
53	437x	year <- floor(year) # Drop decimal part (if any)
54	437x	((year %% 4) == 0) &
55	437x	(year %% 400 != 100) &
56	437x	(year %% 400 != 200) &
57	437x	(year %% 400 != 300)
58		}

1		# MUTATORS
2		#' @include AllGenerics.R
3		NULL
4
5		# Getters ======================================================================
6		#' @export
7		#' @method labels TimeSeries
8	6x	labels.TimeSeries <- function(object, ...) colnames(object)
9
10		#' @rdname labels
11		#' @aliases labels,TimeSeries-method
12		setMethod("labels", "TimeSeries", labels.TimeSeries)
13
14		#' @export
15		#' @method labels TimeIntervals
16	24x	labels.TimeIntervals <- function(object, ...) object@.Id
17
18		#' @rdname labels
19		#' @aliases labels,TimeIntervals-method
20		setMethod("labels", "TimeIntervals", labels.TimeIntervals)
21
22		#' @export
23		#' @method names TimeIntervals
24	2x	names.TimeIntervals <- function(x) x@.Id
25
26		#' @rdname names
27		#' @aliases names,TimeIntervals-method
28		setMethod("names", "TimeIntervals", names.TimeIntervals)
29
30		#' @export
31		#' @method length TimeIntervals
32	6x	length.TimeIntervals <- function(x) length(x@.Id)
33
34		#' @rdname length
35		#' @aliases length,TimeIntervals-method
36		setMethod("length", "TimeIntervals", length.TimeIntervals)
37
38		# Setters ======================================================================
39		#' @export
40		#' @method `names<-` TimeIntervals
41		`names<-.TimeIntervals` <- function(x, value) {
42	1x	if (is.null(value)) value <- paste0("I", seq_len(length(x)))
43	4x	x@.Id <- as.character(value)
44	4x	validObject(x)
45	3x	x
46		}
47
48		#' @rdname names
49		#' @aliases names<-,TimeIntervals-method
50		setMethod("names<-", "TimeIntervals", `names<-.TimeIntervals`)

1		# SPAN
2		#' @include AllGenerics.R
3		NULL
4
5		#' @export
6		#' @rdname span
7		#' @aliases span,TimeSeries-method
8		setMethod(
9		f = "span",
10		signature = c(x = "TimeSeries"),
11		definition = function(x, calendar = NULL) {
12	4x	z <- end(x, calendar = calendar) - start(x, calendar = calendar)
13	4x	unclass(z) * calendar_direction(calendar)
14		}
15		)
16
17		#' @export
18		#' @rdname span
19		#' @aliases span,TimeIntervals-method
20		setMethod(
21		f = "span",
22		signature = c(x = "TimeIntervals"),
23		definition = function(x, calendar = NULL) {
24	4x	z <- end(x, calendar = calendar) - start(x, calendar = calendar)
25	4x	unclass(z) * calendar_direction(calendar)
26		}
27		)

1		# CLASSES VALIDATION
2		#' @include AllClasses.R
3		NULL
4
5		# TimeScale =====================================================================
6		setValidity(
7		Class = "TimeScale",
8		method = function(object) {
9		## Get data
10		label <- object@label
11		name <- object@name
12		epoch <- object@epoch
13		fixed <- object@fixed
14		direction <- object@direction
15		year <- object@year
16
17		## Validate
18		cnd <- list(
19		arkhe::validate(arkhe::assert_length(label, 1)),
20		arkhe::validate(arkhe::assert_length(name, 1)),
21		arkhe::validate(arkhe::assert_length(epoch, 1)),
22		arkhe::validate(arkhe::assert_length(fixed, 1)),
23		arkhe::validate(arkhe::assert_length(direction, 1)),
24		arkhe::validate(arkhe::assert_length(year, 1))
25		)
26
27		## Return conditions, if any
28		arkhe::check_class(object, cnd)
29		}
30		)
31
32		# Time Series ==================================================================
33		# setValidity(
34		# Class = "RataDie",
35		# method = function(object) {
36		#
37		# }
38		# )
39
40		setValidity(
41		Class = "TimeSeries",
42		method = function(object) {
43		## Get data
44		time <- object@.Time
45		m <- nrow(object)
46
47		## Validate
48		cnd <- list(
49		arkhe::validate(arkhe::assert_type(object, "numeric")),
50		arkhe::validate(arkhe::assert_length(time, m)),
51		arkhe::validate(arkhe::assert_infinite(time))
52		)
53
54		## Return conditions, if any
55		arkhe::check_class(object, cnd)
56		}
57		)
58
59		setValidity(
60		Class = "TimeIntervals",
61		method = function(object) {
62		## Get data
63		names <- object@.Id
64		start <- object@.Start
65		end <- object@.End
66		m <- length(start)
67
68		## Validate
69		cnd <- list(
70		arkhe::validate(arkhe::assert_length(names, m)),
71		arkhe::validate(arkhe::assert_length(end, m)),
72		arkhe::validate(arkhe::assert_missing(names)),
73		arkhe::validate(arkhe::assert_missing(start)),
74		arkhe::validate(arkhe::assert_missing(end)),
75		arkhe::validate(assert_ordered(start, end))
76		)
77
78		## Return conditions, if any
79		arkhe::check_class(object, cnd)
80		}
81		)
82
83		assert_ordered <- function(start, end) {
84	23x	arg_start <- deparse(substitute(start))
85	23x	arg_end <- deparse(substitute(end))
86	23x	if (any(start > end)) {
87	1x	msg <- sprintf(tr_("%s is later than %s."), sQuote(arg_start), sQuote(arg_end))
88	1x	stop(msg)
89		}
90	22x	invisible(NULL)
91		}