as.fhx addition

NAMESPACE

@@ -13,6 +13,7 @@ S3method(print,sea)
 S3method(quantile,intervals)
 S3method(sort,fhx)
 S3method(summary,fhx)
+export(as.fhx)
 export(composite)
 export(count_event_position)
 export(count_injury)

NEWS.md

@@ -2,6 +2,8 @@
 
 Changes in this release:
 
+* Added `as.fhx()`. This takes data frames, tibbles, and lists as input. It assumes they have "year", "series", and "rec_type" elements/columns and returns an fhx object. (Issue #120).
+
 * Removed deprecated `run_sea()`. Be sure to use `sea()` now.
 
 * Removed deprecated `get_ggplot()`, please use `plot_demograph()` now.

R/utils.R

@@ -465,6 +465,33 @@ is.fhx <- function(x) {
   inherits(x, 'fhx')
 }
 
+#' Convert to fhx object.
+#'
+#' @param x A data frame or list-like object. Must have named elements or columns for "year", "series", and "rec_type".
+#'
+#' @return Boolean indicating whether `x` is an fhx object.
+#'
+#' @details
+#' The "year", "series", and "rec_type" in \code{x} will be pass through \code{as.numeric}, \code{as.factor}, and \code{burnr::make_rec_type} before being passed to \code{burnr::fhx}.
+#'
+#' @examples
+#' data(lgr2)
+#' example_dataframe <- as.data.frame(lgr2)
+#' back_to_fhx <- as.fhx(example_dataframe)
+#'
+#' @export
+as.fhx <- function(x) {
+  if (!all(c("year", "series", "rec_type") %in% names(x))) {
+    stop("`x` must have members 'year', 'series', and 'rec_type'")
+  }
+
+  yr <- as.numeric(x$year)
+  series <- as.factor(x$series)
+  record <- make_rec_type(x$rec_type)
+
+  fhx(yr, series, record)
+}
+
 #' Check for duplicate observations in an fhx object.
 #'
 #' @param x An fhx object.

tests/testthat/test-utils.R

@@ -170,4 +170,46 @@ test_that("check_duplicates throws error when fhx obj has duplicates", {
                "*Please resolve duplicate records*")
 })
 
+test_that("as.fhx works on data.frame input", {
+  yrs <- c(1850, 2010)
+  series_chr <- c("a", "a")
+  events_chr <- c("pith_year", "bark_year")
+
+  test_df <- data.frame(year = yrs,
+                        series = series_chr,
+                        rec_type = events_chr)
+
+  new_fhx <- burnr::as.fhx(test_df)
+  expect_equal(new_fhx$year, yrs)
+  expect_equal(new_fhx$series, factor(series_chr))
+  expect_equal(new_fhx$rec_type, burnr::make_rec_type(events_chr))
+})
+
+test_that("as.fhx works on list input", {
+  yrs <- c(1850, 2010)
+  series_chr <- c("a", "a")
+  events_chr <- c("pith_year", "bark_year")
+
+  test_df <- list(year = yrs,
+                  series = series_chr,
+                  rec_type = events_chr)
+
+  new_fhx <- burnr::as.fhx(test_df)
+  expect_equal(new_fhx$year, yrs)
+  expect_equal(new_fhx$series, factor(series_chr))
+  expect_equal(new_fhx$rec_type, burnr::make_rec_type(events_chr))
+})
+
+test_that("as.fhx throws error when input missing key element", {
+  yrs <- c(1850, 2010)
+  series_chr <- c("a", "a")
+  events_chr <- c("pith_year", "bark_year")
+
+  test_df <- list(year = yrs,
+                  serie = series_chr,  # bad spelling
+                  rec_type = events_chr)
+
+  expect_error(burnr:::as.fhx(test_df), 
+               "`x` must have members 'year', 'series', and 'rec_type'")
+})