diff --git a/NEWS.md b/NEWS.md index aef84c5..d175781 100644 --- a/NEWS.md +++ b/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. diff --git a/R/io.R b/R/io.R index e69d3a4..45d01a9 100644 --- a/R/io.R +++ b/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 = ""), diff --git a/R/sysdata.rda b/R/sysdata.rda index 75b9a8d..080ed17 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/utils.R b/R/utils.R index 2e0f8e4..93816ad 100644 --- a/R/utils.R +++ b/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 +} diff --git a/data-raw/sysdata.R b/data-raw/sysdata.R index aeee004..6839278 100644 --- a/data-raw/sysdata.R +++ b/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,7 +46,11 @@ 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", @@ -46,7 +58,11 @@ rec_type_injury <- c( "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", @@ -54,7 +70,11 @@ rec_type_scar <- 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_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 ) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 174f7b7..f2abc48 100644 --- a/tests/testthat/test-utils.R +++ b/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)) +}) +