Fix S3 methods for S4 objects

tesselle · Nov 12, 2024 · c10eeb9 · c10eeb9
1 parent 9cdf61c
commit c10eeb9
Show file tree

Hide file tree

Showing 15 changed files with 157 additions and 143 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -2,12 +2,22 @@
 
 S3method(as.data.frame,TimeIntervals)
 S3method(as.data.frame,TimeSeries)
+S3method(end,TimeIntervals)
+S3method(end,TimeSeries)
+S3method(format,RataDie)
+S3method(format,TimeScale)
+S3method(frequency,TimeSeries)
 S3method(image,TimeSeries)
 S3method(labels,TimeIntervals)
 S3method(labels,TimeSeries)
 S3method(length,TimeIntervals)
 S3method(plot,TimeIntervals)
 S3method(plot,TimeSeries)
+S3method(pretty,RataDie)
+S3method(start,TimeIntervals)
+S3method(start,TimeSeries)
+S3method(time,TimeSeries)
+S3method(window,TimeSeries)
 export(AD)
 export(BC)
 export(BCE)
@@ -30,6 +40,8 @@ export(fixed_to_CE)
 export(fixed_to_b2k)
 export(fixed_to_julian)
 export(year_axis)
+exportClasses(GregorianCalendar)
+exportClasses(JulianCalendar)
 exportClasses(RataDie)
 exportClasses(TimeIntervals)
 exportClasses(TimeScale)

diff --git a/R/AllClasses.R b/R/AllClasses.R
@@ -43,10 +43,9 @@ NULL
 #' @author N. Frerebeau
 #' @family classes
 #' @family calendar classes
-#' @family gregorian era classes
 #' @docType class
 #' @aliases GregorianCalendar-class
-#' @keywords internal
+#' @exportClass GregorianCalendar
 .GregorianCalendar <- setClass(
   Class = "GregorianCalendar",
   prototype = list(
@@ -67,7 +66,7 @@ NULL
 #' @family calendar classes
 #' @docType class
 #' @aliases JulianCalendar-class
-#' @keywords internal
+#' @exportClass JulianCalendar
 .JulianCalendar <- setClass(
   Class = "JulianCalendar",
   prototype = list(

diff --git a/R/AllGenerics.R b/R/AllGenerics.R
@@ -447,6 +447,7 @@ setGeneric(
 #'  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
@@ -559,6 +560,7 @@ setGeneric(
 #' @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
@@ -578,6 +580,7 @@ NULL
 #' @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
@@ -598,6 +601,7 @@ NULL
 #'  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

diff --git a/R/calendar.R b/R/calendar.R
@@ -24,7 +24,7 @@ setMethod(
 )
 
 #' @export
-#' @describeIn gregorian Gregorian BP era.
+#' @rdname gregorian
 BP <- function(...) {
   .GregorianCalendar(
     label = tr_("BP"),
@@ -35,7 +35,7 @@ BP <- function(...) {
 }
 
 #' @export
-#' @describeIn gregorian Gregorian b2k era.
+#' @rdname gregorian
 b2k <- function(...) {
   .GregorianCalendar(
     label = tr_("b2k"),
@@ -46,7 +46,7 @@ b2k <- function(...) {
 }
 
 #' @export
-#' @describeIn gregorian Gregorian BC era.
+#' @rdname gregorian
 BC <- function(...) {
   .GregorianCalendar(
     label = tr_("BC"),
@@ -56,7 +56,7 @@ BC <- function(...) {
 }
 
 #' @export
-#' @describeIn gregorian Gregorian BCE era.
+#' @rdname gregorian
 BCE <- function(...) {
   .GregorianCalendar(
     label = tr_("BCE"),
@@ -66,7 +66,7 @@ BCE <- function(...) {
 }
 
 #' @export
-#' @describeIn gregorian Gregorian AD era.
+#' @rdname gregorian
 AD <- function(...) {
   .GregorianCalendar(
     label = tr_("AD"),
@@ -75,7 +75,7 @@ AD <- function(...) {
 }
 
 #' @export
-#' @describeIn gregorian Gregorian CE era.
+#' @rdname gregorian
 CE <- function(...) {
   .GregorianCalendar(
     label = tr_("CE"),
@@ -84,7 +84,7 @@ CE <- function(...) {
 }
 
 # @export
-# @describeIn gregorian Gregorian AUC era.
+# @rdname gregorian
 # AUC <- function(...) {
 #   .GregorianCalendar(
 #     label = tr_("AUC"),
@@ -104,7 +104,10 @@ J <- function(...) {
 }
 
 # Mutators =====================================================================
-calendar_year <- function(object) object@year
+calendar_year <- function(object) {
+  if (is.null(object)) return(NULL)
+  object@year
+}
 
 ## Getters ---------------------------------------------------------------------
 #' @export

diff --git a/R/show.R b/R/show.R
@@ -2,56 +2,56 @@
 
 # Pretty =======================================================================
 #' @export
-#' @rdname pretty
-setMethod(
-  f = "pretty",
-  signature = "RataDie",
-  definition = function(x, calendar = getOption("aion.calendar"), ...) {
-    if (is.null(calendar)) return(pretty(as.numeric(x), ...))
+#' @method pretty RataDie
+pretty.RataDie <- function(x, calendar = getOption("aion.calendar"), ...) {
+  if (is.null(calendar)) return(pretty(as.numeric(x), ...))
 
-    x <- as_year(x, calendar = calendar)
-    fixed(year = pretty(x, ...), calendar = calendar)
-  }
-)
+  x <- as_year(x, calendar = calendar)
+  fixed(year = pretty(x, ...), calendar = calendar)
+}
+
+#' @export
+#' @rdname pretty
+setMethod("pretty", "RataDie", pretty.RataDie)
 
 # Format =======================================================================
 #' @export
-#' @rdname format
-setMethod(
-  f = "format",
-  signature = "TimeScale",
-  definition = function(x) {
-    msg <- sprintf("%s %s", calendar_unit(x), calendar_label(x))
-    trimws(msg)
-  }
-)
+#' @method format TimeScale
+format.TimeScale <- function(x, ...) {
+  msg <- sprintf("%s %s", calendar_unit(x), calendar_label(x))
+  trimws(msg)
+}
 
 #' @export
 #' @rdname format
-setMethod(
-  f = "format",
-  signature = "RataDie",
-  definition = function(x, prefix = c("a", "ka", "Ma", "Ga"), label = TRUE,
-                        calendar = getOption("aion.calendar")) {
-    if (is.null(calendar)) return(format(as.numeric(x)))
-    y <- as_year(x, calendar = calendar)
+setMethod("format", "TimeScale", format.TimeScale)
 
-    ## 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)
+#' @export
+#' @method format RataDie
+format.RataDie <- function(x, prefix = c("a", "ka", "Ma", "Ga"), label = TRUE,
+                           calendar = getOption("aion.calendar"), ...) {
+  if (is.null(calendar)) return(format(as.numeric(x)))
+  y <- as_year(x, calendar = calendar)
 
-    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))
+  ## 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)
 
 # Show =========================================================================
 setMethod(

diff --git a/R/subset.R b/R/subset.R
@@ -53,18 +53,18 @@ setMethod(
 )
 
 # 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(
-  f = "window",
-  signature = "TimeSeries",
-  definition = 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]
-  }
-)
+setMethod("window", "TimeSeries", window.TimeSeries)