Implement era_year() class

To prepare for transformations between units (#25), the unit parameter of an era definition is now represented with the S3 class era_year, which describes not just the name of the unit but its length in solar days. Incidentally fixes #9.
joeroe · Jan 25, 2021 · 1d4cd7c · 1d4cd7c
1 parent f9d069b
commit 1d4cd7c
Show file tree

Hide file tree

Showing 19 changed files with 301 additions and 57 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(format,era)
+S3method(format,era_year)
 S3method(obj_print_footer,era_yr)
 S3method(obj_print_header,era_yr)
 S3method(pillar_shaft,era_yr)
@@ -34,8 +35,12 @@ export(era_label)
 export(era_name)
 export(era_scale)
 export(era_unit)
+export(era_year)
+export(era_year_days)
+export(era_year_label)
 export(eras)
 export(is_era)
+export(is_era_year)
 export(is_valid_era)
 export(is_valid_yr)
 export(is_yr)

diff --git a/NEWS.md b/NEWS.md
@@ -5,6 +5,7 @@ Second beta / CRAN pre-release.
 * Added new era definitions:
   * Islamic calendars (Lunar Hijri, Solar Hijri).
 * Reworked era definition scheme:
+  * Unit is now represented by the `era_year` class, which describes its length in solar days as well as its name. Added functions for constructing and working with `era_year` objects: `era_year()`, `is_era_year()`, `era_year_label()`, `era_year_days()`.
   * Direction is now coded as `1` ("forwards") or `-1` ("backwards"). The previous character arguments still work but are deprecated.
   * Equality tests for eras now only check significant parameters (i.e. not "label" or "name"), allowing for coercion between functionally equivalent eras, e.g. `yr(1, "BP") + yr(1, "cal BP")` now works (with a warning) (#3).
 * Improved `yr_transform()`:
@@ -15,6 +16,7 @@ Second beta / CRAN pre-release.
   * All `era` arguments in functions can now accept a character vector (#20)
   * `era(<era>)` now returns an era with the same parameters (to enable the above)
   * Various additions to make the [coercion hierarchy](https://vctrs.r-lib.org/reference/theory-faq-coercion.html) for era_yrs more consistent; most notably, the common prototype of era_yr, integer, and double, is now era_yr.
+  * Fixed printing of NA eras (#9)
 
 # era 0.2.0
 

diff --git a/R/era.R b/R/era.R
@@ -18,7 +18,9 @@
 #'  Era).
 #' @param name  Character. Full name of the era. Defaults to the value of
 #'  `label`.
-#' @param unit  Character. Type of years used. Default: `"calendar"`.
+#' @param unit  An [era_year()] object describing the name of the year unit and
+#'  its average length in solar days. Defaults to a Gregorian year
+#'  (365.2425 days).
 #' @param scale  Integer. Number of years represented by one unit, e.g. `1000`
 #'  for ka. Default: 1.
 #' @param direction  Are years counted backwards (`-1`) (the default) or forwards (`1`)
@@ -28,6 +30,7 @@
 #' An object of class `era`.
 #'
 #' @family era definition functions
+#' @family era helper functions
 #'
 #' @export
 #'
@@ -38,7 +41,7 @@
 era <- function(label,
                 epoch = NULL,
                 name = label,
-                unit = c("calendar", "Islamic lunar", "radiocarbon"),
+                unit = era_year("Gregorian"),
                 scale = 1,
                 direction = -1) {
   if (missing(epoch) &&
@@ -77,7 +80,7 @@ era <- function(label,
       label = vec_cast(label, character()),
       epoch = vec_cast(epoch, numeric()),
       name = vec_cast(name, character()),
-      unit = arg_match(unit),
+      unit = vec_assert(unit, new_era_year()),
       scale = vec_cast(scale, integer()),
       direction = vec_cast(direction, integer()),
       stringsAsFactors = FALSE
@@ -239,16 +242,18 @@ is_valid_era <- function(x) {
 #' @keywords internal
 era_problems <- function(x) {
   !c(
-    "era parameters must not be NA" =
-      apply(vec_proxy(x), 1, function(x) !any(is.na(x))),
+    # TODO: Do we need this? Breaks now unit is a rcrd, and maybe some fields
+    #  could be NA?
+    # "era parameters must not be NA" =
+    #   apply(vec_proxy(x), 1, function(x) !any(is.na(x))),
     "`label` must be a character" =
       vec_is(era_label(x), character()),
     "`epoch` must be a numeric" =
       vec_is(era_epoch(x), numeric()),
     "`name` must be a character" =
       vec_is(era_name(x), character()),
-    "`unit` must be one of 'calendar', 'Islamic lunar', 'radiocarbon'" =
-      all(era_unit(x) %in% c("calendar", "Islamic lunar", "radiocarbon")),
+    "`unit` must be an `era_year` object" =
+      is_era_year(era_unit(x)),
     "`scale` must be an integer" =
       vec_is(era_scale(x), integer()),
     "`scale` must be positive" =
@@ -265,13 +270,13 @@ format.era <- function(x, ...) {
   nameout <- paste0(era_name(x), " (", era_label(x), ")")
   nameout[era_name(x) == era_label(x)] <- era_name(x)[era_name(x) == era_label(x)]
 
-  unitout <- paste0(era_unit(x), " (\u00d7", era_scale(x), ")")
-  unitout[era_scale(x) == 1] <- era_unit(x)[era_scale(x) == 1]
+  scaleout <- paste0(era_scale(x), " ")
+  scaleout[era_scale(x) == 1] <- ""
 
   dirout <- c("backwards", "forwards")[(era_direction(x) > 0) + 1]
 
-  out <- paste0(nameout, ": ", unitout, " years, counted ", dirout, " from ",
-                era_epoch(x))
+  out <- paste0(nameout, ": ", scaleout, format(era_unit(x)),
+                ", counted ", dirout, " from ", era_epoch(x))
 
   return(out)
 }
@@ -310,7 +315,7 @@ vec_proxy_equal.era <- function(x, ...) {
 #' * **label** – unique, abbreviated label of the era, e.g. "cal BP"
 #' * **epoch** – year of origin of the era, e.g. 1950 for years Before Present
 #' * **name** – full name of the era, e.g. "calendar years Before Present"
-#' * **unit** – unit of years used, e.g. "calendar years", "radiocarbon years"
+#' * **unit** – unit of years used, an [era_year()] object
 #' * **scale** – multiple of years used, e.g. 1000 for ka/kiloannum
 #' * **direction** – whether years are counted "backwards" or "forwards" from the epoch
 #' #'

diff --git a/R/era_year.R b/R/era_year.R
@@ -0,0 +1,98 @@
+# era_unit.R
+# Functions and methods for S3 class era_year
+
+# Constructors ------------------------------------------------------------
+
+#' Year units
+#'
+#' `era_year` objects describe the unit used for a year as its length in days.
+#' This value is used in an era definition ([era()]) to enable conversions
+#' between eras that use different units (with [yr_transform()]).
+#'
+#' @param label Character. Name of the year unit.
+#' @param days Numeric. Average length of the year in solar days. Defaults to a
+#'  Gregorian year (365.2425 days).
+#'
+#' @return
+#' S3 vector of class `era_year`.
+#'
+#' @family era helper functions
+#'
+#' @export
+#'
+#' @examples
+#' era_year("Julian", 365.25)
+era_year <- function(label, days = 365.2425) {
+  label <- vec_cast(label, character())
+  days <- vec_cast(days, numeric())
+  new_era_year(label, days)
+}
+
+new_era_year <- function(label = character(), days = numeric()) {
+  new_rcrd(list(label = label, days = days), class = c("era_year"))
+}
+
+
+# Validators --------------------------------------------------------------
+
+#' Validation functions for `era_year` objects
+#'
+#' Tests whether an object is of class `era_year` (constructed by [era_year()]).
+#'
+#' @param x Object to test.
+#'
+#' @return
+#' `TRUE` or `FALSE`.
+#'
+#' @family era helper functions
+#'
+#' @export
+#'
+#' @examples
+#' is_era_year(era_year("Julian", 365.25))
+is_era_year <- function(x) {
+  vec_is(x, new_era_year())
+}
+
+
+# Print and format --------------------------------------------------------
+
+#' @export
+format.era_year <- function(x, ...) {
+  paste0(era_year_label(x), " years (", era_year_days(x), " days)")
+}
+
+
+# Getters and setters -----------------------------------------------------
+
+#' Get the parameters of an `era_year` object.
+#'
+#' Extracts a specific parameter from a year unit object constructed by
+#' [era_year()].
+#'
+#' @name era_year_parameters
+#'
+#' @param x An object of class `era_year`.
+#'
+#' @return
+#' Value of the parameter.
+#'
+#' @family era helper functions
+#'
+#' @examples
+#' julian <- era_year("Julian", 365.25)
+#' era_year_label(julian)
+#' era_year_days(julian)
+NULL
+
+#' @rdname era_year_parameters
+#' @export
+era_year_label <- function(x) {
+  field(x, "label")
+}
+
+#' @rdname era_year_parameters
+#' @export
+era_year_days <- function(x) {
+  field(x, "days")
+}
diff --git a/R/sysdata.rda b/R/sysdata.rda
diff --git a/R/transform.R b/R/transform.R
@@ -50,8 +50,8 @@ yr_transform <- function(x, era = yr_era(x), precision = NA) {
       paste0("Can't transform era ", era_label(src_era), " to ", era_label(dst_era), ":"),
       class = "era_invalid_transform",
       body = format_error_bullets(c(
-        x = paste0("Can't convert ", era_unit(src_era), " to ",
-                   era_unit(dst_era), " years.")
+        x = paste0("Can't convert ", era_year_label(era_unit(src_era)), " to ",
+                   era_year_label(era_unit(dst_era)), " years.")
         ))
       )
   }

diff --git a/README.md b/README.md
@@ -41,7 +41,7 @@ x <- yr(c(9000, 8000, 7000), "cal BP")
 x
 #> # cal BP years <yr[3]>:
 #> [1] 9000 8000 7000
-#> # Era: Before Present (cal BP): calendar years, counted backwards from 1950
+#> # Era: Before Present (cal BP): Gregorian years (365.2425 days), counted backwards from 1950
 ```
 
 Use `yr_transform()` to convert between eras:
@@ -50,7 +50,7 @@ Use `yr_transform()` to convert between eras:
 yr_transform(x, "BCE")
 #> # BCE years <yr[3]>:
 #> [1] 7050 6050 5050
-#> # Era: Before Common Era (BCE): calendar years, counted backwards from 0
+#> # Era: Before Common Era (BCE): Gregorian years (365.2425 days), counted backwards from 0
 ```
 
 Many common calendar systems and time scales are predefined (see

diff --git a/data-raw/era_table.R b/data-raw/era_table.R
@@ -3,53 +3,61 @@
 library("tibble")
 library("usethis")
 
+# Unit definitions
+gregorian <- era_year("Gregorian", 365.2425)
+julian <- era_year("Julian", 365.25)
+solar <- era_year("solar", 365.24219)
+islamic_lunar <- era_year("Islamic lunar", 354.36708)
+radiocarbon <- era_year("radiocarbon", NA)
+
 era_table <- tribble(
   # label must be unique
-  ~label,      ~epoch,  ~name,                                   ~unit,          ~scale,  ~direction,
+  ~label,      ~epoch,  ~name,                                   ~unit,         ~scale,  ~direction,
   # Before Present
-  "BP",        1950,    "Before Present",                        "calendar",       1L,    -1,
-  "cal BP",    1950,    "Before Present",                        "calendar",       1L,    -1,
+  "BP",        1950,    "Before Present",                        gregorian,      1L,    -1,
+  "cal BP",    1950,    "Before Present",                        gregorian,      1L,    -1,
   # Common Era (English)
-  "BC",        0,       "Before Christ",                         "calendar",       1L,    -1,
-  "BCE",       0,       "Before Common Era",                     "calendar",       1L,    -1,
-  "AD",        0,       "Anno Domini",                           "calendar",       1L,    1,
-  "CE",        0,       "Common Era",                            "calendar",       1L,    1,
+  "BC",        0,       "Before Christ",                         gregorian,      1L,    -1,
+  "BCE",       0,       "Before Common Era",                     gregorian,      1L,    -1,
+  "AD",        0,       "Anno Domini",                           gregorian,      1L,    1,
+  "CE",        0,       "Common Era",                            gregorian,      1L,    1,
   # SI annus
-  "ka",        1950,    "kiloannum",                             "calendar",       1000L, -1,
-  "Ma",        1950,    "megaannum",                             "calendar",       1e6L,  -1,
-  "Ga",        1950,    "gigaannum",                             "calendar",       1e9L,  -1,
+  "ka",        1950,    "kiloannum",                             gregorian,      1000L, -1,
+  "Ma",        1950,    "megaannum",                             gregorian,      1e6L,  -1,
+  "Ga",        1950,    "gigaannum",                             gregorian,      1e9L,  -1,
   # Pseudo-SI annus
-  "kya",       1950,    "thousand years ago",                    "calendar",       1000L, -1,
-  "mya",       1950,    "million years ago",                     "calendar",       1e6L,  -1,
-  "bya",       1950,    "billion years ago",                     "calendar",       1e9L,  -1,
+  "kya",       1950,    "thousand years ago",                    gregorian,      1000L, -1,
+  "mya",       1950,    "million years ago",                     gregorian,      1e6L,  -1,
+  "bya",       1950,    "billion years ago",                     gregorian,      1e9L,  -1,
   # GICC05 (b2k)
   # https://www.iceandclimate.nbi.ku.dk/research/strat_dating/annual_layer_count/gicc05_time_scale/
-  "b2k",       2000,    "years before 2000",                     "calendar",       1L,    -1,
+  "b2k",       2000,    "years before 2000",                     gregorian,      1L,    -1,
   # ISO 80000
   # Uncalibrated radiocarbon years
-  "uncal BP",  1950,    "uncalibrated Before Present",           "radiocarbon",    1L,    -1,
-  "RCYBP",     1950,    "Radiocarbon Years Before Present",      "radiocarbon",    1L,    -1,
-  "bp",        1950,    "Before Present (uncalibrated)",         "radiocarbon",    1L,    -1,
-  "bc",        1950,    "Before Christ (uncalibrated)",          "radiocarbon",    1L,    -1,
-  "bce",       1950,    "Before Common Era (uncalibrated)",      "radiocarbon",    1L,    -1,
-  "ad",        1950,    "Anno Domini (uncalibrated)",            "radiocarbon",    1L,    1,
-  "ce",        1950,    "Common Era (uncalibrated)",             "radiocarbon",    1L,    1,
+  "uncal BP",  1950,    "uncalibrated Before Present",           radiocarbon,    1L,    -1,
+  "RCYBP",     1950,    "Radiocarbon Years Before Present",      radiocarbon,    1L,    -1,
+  "bp",        1950,    "Before Present (uncalibrated)",         radiocarbon,    1L,    -1,
+  "bc",        1950,    "Before Christ (uncalibrated)",          radiocarbon,    1L,    -1,
+  "bce",       1950,    "Before Common Era (uncalibrated)",      radiocarbon,    1L,    -1,
+  "ad",        1950,    "Anno Domini (uncalibrated)",            radiocarbon,    1L,    1,
+  "ce",        1950,    "Common Era (uncalibrated)",             radiocarbon,    1L,    1,
   # Common Era aliases and translations
   # Contemporary calendars
   # Islamic calendars
-  "AH",        622,     "Anno Hegirae",                          "Islamic lunar",  1L,    1,
-  "BH",        622,     "Before the Hijra",                      "Islamic lunar",  1L,    -1,
-  "SH",        622,     "Solar Hijri",                           "calendar",       1L,    1,
-  "BSH",       622,     "Before Solar Hijri",                    "calendar",       1L,     1,
+  "AH",        622,     "Anno Hegirae",                          islamic_lunar,  1L,    1,
+  "BH",        622,     "Before the Hijra",                      islamic_lunar,  1L,    -1,
+  "SH",        622,     "Solar Hijri",                           gregorian,      1L,    1,
+  "BSH",       622,     "Before Solar Hijri",                    gregorian,      1L,     1,
   # Historic calendars
   # Ancient calendars
   # Quirky calendars
-  "HE",        -10000,  "Holocene Era",                          "calendar",       1L,    1,
-  "BHE",       -10000,  "Before Holocene Era",                   "calendar",       1L,    -1,
-  "AL",        -4000,   "Anno Lucis",                            "calendar",       1L,    1,
-  "ADA",       -8000,   "After the Development of Agriculture",  "calendar",       1L,    1,
+  "HE",        -10000,  "Holocene Era",                          gregorian,      1L,    1,
+  "BHE",       -10000,  "Before Holocene Era",                   gregorian,      1L,    -1,
+  "AL",        -4000,   "Anno Lucis",                            gregorian,      1L,    1,
+  "ADA",       -8000,   "After the Development of Agriculture",  gregorian,      1L,    1,
 )
 
-era_table <- as.data.frame(era_table)
+# Unlist unit column
+era_table$unit <- do.call(vctrs::vec_c, era_table$unit)
 
 use_data(era_table, overwrite = TRUE, internal = TRUE)
diff --git a/man/era.Rd b/man/era.Rd
diff --git a/man/era_parameters.Rd b/man/era_parameters.Rd