Add new rec_types & write_fhx warning, close #149

NEWS.md

@@ -6,6 +6,8 @@ Changes in this release:
 
 * Extensive improvement to documentation (e.g. Issue #145). This includes new "See Also" sections so users can find cool functions, fixes for spelling errors, and clarifications to dyslexic prose.
 
+* `write_fhx()` will now throw a warning if users try to write an `fhx` object that has records types that violate the FHX2 file standard (Issue #149). I strongly recommend using `write.csv(...)` on `fhx` objects and `as.fhx(read.csv(...))` for IO with experimental `fhx` data.
+
 * Removed deprecated `run_sea()`. Be sure to use `sea()` now.
 
 * Removed deprecated `get_ggplot()`. Please use `plot_demograph()` now.

R/io.R

@@ -204,6 +204,12 @@ write_fhx <- function(x, fname = "") {
     stop("Please specify a character string naming a file or connection open
           for writing.")
   }
+  if (violates_canon(x)) {
+    warning(
+      "`write_fhx()` run on `fhx` object with rec_types that violate FHX2", 
+      " canon - other software may not be able to read the output FHX file"
+    )
+  }
   d <- list_filestrings(x)
   fl <- file(fname, open = "wt")
   cat(paste(d[["head_line"]], "\n", d[["subhead_line"]], "\n", sep = ""),

R/utils.R

@@ -724,3 +724,19 @@ check_duplicates <- function(x) {
     ))
   }
 }
+
+
+#' Test if `fhx` object respects canon FHX2 format
+#'
+#' @param x An `fhx` object.
+#'
+#' @return Boolean. Does `x` violate the canon format?
+#'
+#' @details
+#' Checks `x` "rec_type" to see if it uses experimental or non-canon events
+#' that go against the vanilla FHX2 file format.
+#'
+#' @noRd
+violates_canon <- function(x) {
+  !all(x$rec_type %in% rec_type_canon)  # nolint
+}

data-raw/sysdata.R

@@ -3,7 +3,6 @@ library(burnr)
 
 
 type_key <- list(
-  "?" = "estimate", # My own creation for estimated years to pith.
   "." = "null_year",
   "|" = "recorder_year",
   "U" = "unknown_fs",
@@ -21,7 +20,16 @@ type_key <- list(
   "[" = "pith_year",
   "]" = "bark_year",
   "{" = "inner_year",
-  "}" = "outer_year"
+  "}" = "outer_year",
+  "?" = "estimate",  # non-canon for estimated years to pith.
+  "T" = "transition_fs",  # noncanon
+  "t" = "transition_fi",  # noncanon
+  "F" = "falldormant_fs",  # noncanon
+  "f" = "falldormant_fi",  # noncanon
+  "B" = "earlylw_fs",  # noncanon
+  "b" = "earlylw_fi",  # noncanon
+  "C" = "latelw_fs",  # noncanon
+  "c" = "latelw_fi"  # noncanon
 )
 
 rec_type_all <- unlist(type_key)
@@ -38,23 +46,35 @@ rec_type_recorder <- c(
   "early_fs",
   "middle_fs",
   "late_fs",
-  "latewd_fs"
+  "latewd_fs",
+  "transition_fs",  # noncanon
+  "falldormant_fs",  # noncanon
+  "earlylw_fs",  # noncanon
+  "latelw_fs"  # noncanon
 )
 rec_type_injury <- c(
   "unknown_fi",
   "dormant_fi",
   "early_fi",
   "middle_fi",
   "late_fi",
-  "latewd_fi"
+  "latewd_fi",
+  "transition_fi",  # noncanon
+  "falldormant_fi",  # noncanon
+  "earlylw_fi",  # noncanon
+  "latelw_fi"  # noncanon
 )
 rec_type_scar <- c(
   "unknown_fs",
   "dormant_fs",
   "early_fs",
   "middle_fs",
   "late_fs",
-  "latewd_fs"
+  "latewd_fs",
+  "transition_fs",  # noncanon
+  "falldormant_fs",  # noncanon
+  "earlylw_fs",  # noncanon
+  "latelw_fs"  # noncanon
 )
 rec_type_ends <- c(
   "pith_year",
@@ -63,7 +83,30 @@ rec_type_ends <- c(
   "outer_year"
 )
 
+# Only "official" canon rec_types go here:
+rec_type_canon <- c(
+  "null_year",
+  "recorder_year",
+  "unknown_fs",
+  "unknown_fi",
+  "dormant_fs",
+  "dormant_fi",
+  "early_fs",
+  "early_fi",
+  "middle_fs",
+  "middle_fi",
+  "late_fs",
+  "late_fi",
+  "latewd_fs",
+  "latewd_fi",
+  "pith_year",
+  "bark_year",
+  "inner_year",
+  "outer_year"
+)
+
 usethis::use_data(rec_type_all, rec_type_abrv,
   rec_type_recorder, rec_type_injury, rec_type_scar, rec_type_ends,
+  rec_type_canon,
   internal = TRUE, overwrite = TRUE
 )

tests/testthat/test-utils.R

@@ -14,14 +14,14 @@ test_that("spotcheck get_series", {
 test_that("make_rec_type handles single character vector", {
   test_subj <- make_rec_type("late_fs")
   expect_true(is.factor(test_subj))
-  expect_equal(length(levels(test_subj)), 19)
+  expect_equal(length(levels(test_subj)), length(burnr:::rec_type_all))
 })
 
 test_that("make_rec_type handles multiple character vector", {
   test_subj <- make_rec_type(c("null_year", "late_fs"))
   expect_equal(length(test_subj), 2)
   expect_true(is.factor(test_subj))
-  expect_equal(length(levels(test_subj)), 19)
+  expect_equal(length(levels(test_subj)), length(burnr:::rec_type_all))
 })
 
 test_that("make_rec_type throws error on bad levels", {
@@ -257,3 +257,22 @@ test_that("as_fhx throws error when input missing key element", {
     "`x` must have members 'year', 'series', and 'rec_type'"
   )
 })
+
+
+test_that("internal violates_canon catches bad, passes good", {
+  test_case_good <- fhx(
+    year = c(1850, 2010),
+    series = c("a", "a"),
+    rec_type = c("pith_year", "bark_year")
+  )
+
+  test_case_bad <- fhx(
+    year = c(1850, 2010),
+    series = c("a", "a"),
+    rec_type = c("pith_year", "estimate")
+  )
+
+  expect_true(!burnr:::violates_canon(test_case_good))
+  expect_true(burnr:::violates_canon(test_case_bad))
+})
+