Add an easy way to get and set the default calendar

tesselle · Jan 2, 2025 · edc47e7 · edc47e7
1 parent fc88ee0
commit edc47e7
Show file tree

Hide file tree

Showing 30 changed files with 174 additions and 83 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -56,6 +56,7 @@ Collate:
     'coerce.R'
     'convert.R'
     'data.R'
+    'format.R'
     'intervals.R'
     'mutators.R'
     'operators.R'

diff --git a/NAMESPACE b/NAMESPACE
@@ -39,6 +39,8 @@ export(fixed_to_BP)
 export(fixed_to_CE)
 export(fixed_to_b2k)
 export(fixed_to_julian)
+export(get_calendar)
+export(set_calendar)
 export(year_axis)
 exportClasses(RataDie)
 exportClasses(TimeIntervals)

diff --git a/NEWS.md b/NEWS.md
@@ -1,4 +1,6 @@
 # aion 1.3.0.9000
+## New classes and methods
+* Add `get_calendar()` and `set_calendar()` to get and set the default calendar.
 
 # aion 1.3.0
 ## New classes and methods

diff --git a/R/AllGenerics.R b/R/AllGenerics.R
@@ -90,8 +90,7 @@ NULL
 #' Calendar
 #'
 #' @param object A [`character`] string specifying the abbreviated label of
-#'  the time scale (see details) or an object from which to extract the time
-#'  scale.
+#'  the time scale (see details).
 #' @details
 #'  The following time scales are available:
 #'
@@ -148,6 +147,21 @@ NULL
 #' @rdname julian
 NULL
 
+#' Get or Set the Default Calendar
+#'
+#' @param label A [`character`] string specifying the abbreviated label of
+#'  the time scale (see [calendar()]).
+#' @param ... Currently not used.
+#' @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
+
 #' Is an Object a Calendar?
 #'
 #' Test inheritance relationships between an object and a calendar class.

diff --git a/R/aion-package.R b/R/aion-package.R
@@ -9,10 +9,8 @@
 #'
 #' @section Package options:
 #'  \pkg{aion} uses the following [options()] to configure behaviour:
-#'  * `aion.precision`: an [`integer`] indicating the number of decimal
-#'    places (defaults to `NA`).
-#'  * `aion.calendar`: a [`TimeScale-class`] object (default calendar for
-#'    printing).
+#'  * `aion.calendar`: a function that returns a [`TimeScale-class`] object
+#'    specifying the default calendar (see [get_calendar()]).
 #'
 #' @author
 #'  **Full list of authors and contributors** (alphabetic order):

diff --git a/R/axis.R b/R/axis.R
@@ -3,7 +3,7 @@
 # Pretty =======================================================================
 #' @export
 #' @method pretty RataDie
-pretty.RataDie <- function(x, calendar = getOption("aion.calendar"), ...) {
+pretty.RataDie <- function(x, calendar = get_calendar(), ...) {
   if (is.null(calendar)) return(pretty(as.numeric(x), ...))
 
   x <- as_year(x, calendar = calendar, decimal = FALSE)
@@ -16,45 +16,6 @@ pretty.RataDie <- function(x, calendar = getOption("aion.calendar"), ...) {
 #' @rdname pretty
 setMethod("pretty", "RataDie", pretty.RataDie)
 
-# Format =======================================================================
-#' @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 = getOption("aion.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)
-
 # Axis =========================================================================
 #' @export
 #' @rdname year_axis

diff --git a/R/calendar.R b/R/calendar.R
@@ -92,6 +92,22 @@ J <- function(...) {
   )
 }
 
+# Default calendar =============================================================
+#' @export
+#' @rdname get_calendar
+get_calendar <- function(...) {
+  cal <- getOption("aion.calendar", default = function(...) calendar("CE"))
+  cal()
+}
+
+#' @export
+#' @rdname get_calendar
+set_calendar <- function(label) {
+  cal <- function(...) calendar(label)
+  options(aion.calendar = cal)
+  invisible(cal())
+}
+
 # Mutators =====================================================================
 ## Getters ---------------------------------------------------------------------
 #' @export

diff --git a/R/format.R b/R/format.R
@@ -0,0 +1,40 @@
+# FORMAT
+
+# Format =======================================================================
+#' @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)
diff --git a/R/plot.R b/R/plot.R
@@ -5,7 +5,7 @@ NULL
 # Plot =========================================================================
 #' @export
 #' @method plot TimeIntervals
-plot.TimeIntervals <- function(x, calendar = getOption("aion.calendar"),
+plot.TimeIntervals <- function(x, calendar = get_calendar(),
                                sort = TRUE, decreasing = FALSE,
                                xlab = NULL, ylab = NULL,
                                main = NULL, sub = NULL,
@@ -77,7 +77,11 @@ plot.TimeIntervals <- function(x, calendar = getOption("aion.calendar"),
 
   ## Add annotation
   if (ann) {
-    cal_lab <- if (is.null(calendar)) expression(italic("rata die")) else format(calendar)
+    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)
   }
@@ -93,7 +97,7 @@ setMethod("plot", c(x = "TimeIntervals", y = "missing"), plot.TimeIntervals)
 #' @export
 #' @method plot TimeSeries
 plot.TimeSeries <- function(x, facet = c("multiple", "single"),
-                            calendar = getOption("aion.calendar"),
+                            calendar = get_calendar(),
                             panel = graphics::lines, flip = FALSE, ncol = NULL,
                             xlab = NULL, ylab = NULL,
                             main = NULL, sub = NULL,
@@ -220,9 +224,12 @@ setMethod("plot", c(x = "TimeSeries", y = "missing"), plot.TimeSeries)
 
   ## Add annotation
   if (ann) {
-    cal_lab <- if (is.null(calendar)) expression(italic("rata die")) else format(calendar)
+    if (is.null(calendar)) {
+      cal_lab <- expression(italic("rata die"))
+    } else {
+      cal_lab <- format(calendar)
+    }
     xlab <- xlab %||% cal_lab
-    # ylab <- NULL
     graphics::title(main = main, sub = sub, xlab = xlab, ylab = ylab)
   }
 
@@ -372,7 +379,7 @@ xlim <- function(x, calendar, finite = FALSE) {
 # Image ========================================================================
 #' @export
 #' @method image TimeSeries
-image.TimeSeries <- function(x, calendar = getOption("aion.calendar"), k = 1, ...) {
+image.TimeSeries <- function(x, calendar = get_calendar(), k = 1, ...) {
   ## Save calendar for further use, e.g. year_axis()
   options(aion.last_calendar = calendar)
 

diff --git a/R/show.R b/R/show.R
@@ -12,7 +12,7 @@ setMethod(
 
     era <- ""
     if (has_name && has_label) {
-      era <- sprintf("%s (%s): ", calendar_name(object), calendar_label(object))
+      era <- sprintf("%s (%s): ", cal_name, cal_label)
     }
 
     if (calendar_direction(object) > 0) {

diff --git a/R/zzz.R b/R/zzz.R
@@ -1,8 +1,7 @@
 .onLoad <- function(libname, pkgname) {
   op <- options()
   op.aion <- list(
-    aion.precision = 1,
-    aion.calendar = calendar("CE")
+    aion.calendar = NULL
   )
   toset <- !(names(op.aion) %in% names(op))
   if(any(toset)) options(op.aion[toset])

diff --git a/inst/tinytest/test_calendar.R b/inst/tinytest/test_calendar.R
@@ -1,5 +1,10 @@
 Sys.setenv(LANGUAGE = "en") # Force locale
-options(aion.calendar = calendar("CE"))
+
+# Default calendar =============================================================
+expect_identical(get_calendar(), CE())
+expect_identical(set_calendar("BCE"), BCE())
+expect_identical(get_calendar(), BCE())
+set_calendar("CE") # Reset
 
 # Unknown calendar =============================================================
 expect_error(calendar("XXX"), "Unknown calendar")

diff --git a/inst/tinytest/test_intervals.R b/inst/tinytest/test_intervals.R
@@ -1,5 +1,4 @@
-Sys.setlocale("LC_MESSAGES", 'en_GB.UTF-8') # Force locale
-options(aion.calendar = calendar("CE"))
+Sys.setenv(LANGUAGE = "en") # Force locale
 
 # Create =======================================================================
 lower <- c(625, 700, 1200, 1225, 1250, 500, 1000, 1200,

diff --git a/inst/tinytest/test_plot.R b/inst/tinytest/test_plot.R
@@ -6,8 +6,7 @@ if (at_home()) {
   options(tinysnapshot_tol = 200) # pixels
   options(tinysnapshot_os = "Linux")
 
-  Sys.setlocale("LC_MESSAGES", 'en_GB.UTF-8') # Force locale
-  options(aion.calendar = calendar("CE"))
+  Sys.setenv(LANGUAGE = "en") # Force locale
 
   # Plot multiple ==============================================================
   X <- series(

diff --git a/inst/tinytest/test_series.R b/inst/tinytest/test_series.R
@@ -1,5 +1,4 @@
 Sys.setenv(LANGUAGE = "en") # Force locale
-options(aion.calendar = calendar("CE"))
 
 # Create from vector ===========================================================
 x <- rnorm(91)

diff --git a/inst/tinytest/test_show.R b/inst/tinytest/test_show.R
@@ -1,5 +1,4 @@
-Sys.setlocale("LC_MESSAGES", 'en_GB.UTF-8') # Force locale
-options(aion.calendar = calendar("CE"))
+Sys.setenv(LANGUAGE = "en") # Force locale
 
 # Format =======================================================================
 expect_identical(format(CE()), "Gregorian years CE")

diff --git a/inst/tinytest/test_zero.R b/inst/tinytest/test_zero.R
@@ -1,5 +1,4 @@
-Sys.setlocale("LC_MESSAGES", 'en_GB.UTF-8') # Force locale
-options(aion.calendar = calendar("CE"))
+Sys.setenv(LANGUAGE = "en") # Force locale
 
 # Year zero ====================================================================
 ## Julian calendar -------------------------------------------------------------

diff --git a/man/aion-package.Rd b/man/aion-package.Rd
diff --git a/man/calendar.Rd b/man/calendar.Rd
diff --git a/man/calendar_get.Rd b/man/calendar_get.Rd
diff --git a/man/convert.Rd b/man/convert.Rd
diff --git a/man/format.Rd b/man/format.Rd