Merge e4c90c1 into 045ff85

ltrr-arizona-edu · Jul 24, 2019 · db5cd50 · db5cd50
2 parents 045ff85 + e4c90c1
commit db5cd50
Show file tree

Hide file tree

Showing 8 changed files with 137 additions and 89 deletions.
diff --git a/R/io.R b/R/io.R
@@ -39,25 +39,6 @@ read_fhx <- function(fname, encoding, text) {
   }
   # TODO: Need error check that row length = describe[2] + year.
   # TODO: Need error check that first year in body is first year in meta.
-  type_key <- list("?" = "estimate",  # My own creation for estimated years to pith.
-                   "." = "null_year",
-                   "|" = "recorder_year",
-                   "U" = "unknown_fs",
-                   "u" = "unknown_fi",
-                   "D" = "dormant_fs",
-                   "d" = "dormant_fi",
-                   "E" = "early_fs",
-                   "e" = "early_fi",
-                   "M" = "middle_fs",
-                   "m" = "middle_fi",
-                   "L" = "late_fs",
-                   "l" = "late_fi",
-                   "A" = "latewd_fs",
-                   "a" = "latewd_fi",
-                   "[" = "pith_year",
-                   "]" = "bark_year",
-                   "{" = "inner_year",
-                   "}" = "outer_year")
   # Parse series names.
   ## use lapply function to eliminate extra speces at end of id blocks
   id_block <- fl[(first + 2):(first + 1 + describe[3])]
@@ -99,11 +80,12 @@ read_fhx <- function(fname, encoding, text) {
   fl_body_melt <- reshape2::melt(fl_body, id.vars = "year", value.name = "rec_type",
                                  variable.name = "series", na.rm = TRUE)
   fl_body_melt <- fl_body_melt[fl_body_melt$rec_type != '.', ]
-  fl_body_melt$rec_type <- vapply(fl_body_melt$rec_type, function(x) type_key[[x]], "a")
+  fl_body_melt$rec_type <- vapply(fl_body_melt$rec_type, abrv2rec_type, "")
   fl_body_melt$rec_type <- make_rec_type(fl_body_melt$rec_type)
   f <- fhx(year = fl_body_melt$year, series = fl_body_melt$series,
            rec_type = fl_body_melt$rec_type)
 }
+
 #' List of character strings to write to FHX file.
 #'
 #' @param x An fhx object.
@@ -115,26 +97,8 @@ read_fhx <- function(fname, encoding, text) {
 #' @seealso write_fhx
 list_filestrings <- function(x) {
   stopifnot(is.fhx(x))
-  type_key <- list("null_year"    = ".",
-                   "recorder_year"= "|",
-                   "unknown_fs"   = "U",
-                   "unknown_fi"   = "u",
-                   "dormant_fs"   = "D",
-                   "dormant_fi"   = "d",
-                   "early_fs"     = "E",
-                   "early_fi"     = "e",
-                   "middle_fs"    = "M",
-                   "middle_fi"    = "m",
-                   "late_fs"      = "L",
-                   "late_fi"      = "l",
-                   "latewd_fs"    = "A",
-                   "latewd_fi"    = "a",
-                   "pith_year"    = "[",
-                   "bark_year"    = "]",
-                   "inner_year"   = "{",
-                   "outer_year"   = "}")
   out <- x
-  out$rec_type <- vapply(out$rec_type, function(x) type_key[[x]], "a")
+  out$rec_type <- vapply(out$rec_type, rec_type2abrv, "")
   year_range <- seq(min(out$year), max(out$year))
   filler <- data.frame(year = year_range,
                        series = rep("hackishSolution", length(year_range)),
@@ -195,3 +159,23 @@ write_fhx <- function(x, fname="") {
                      row.names = FALSE, col.names = FALSE)
   close(fl)
 }
+
+#' Convert abreviated fhx file event char to rec_type char.
+#'
+#' @param x A character string.
+#'
+#' @return A character string.
+#'
+abrv2rec_type <- function(x) {
+  rec_type_all[[as.character(x)]]
+}
+
+#' Convert rec_type char to abreviated fhx file event char.
+#'
+#' @param x A character string.
+#'
+#' @return A character string.
+#'
+rec_type2abrv <- function(x) {
+  rec_type_abrv[[as.character(x)]]
+}
diff --git a/R/sysdata.rda b/R/sysdata.rda
diff --git a/R/utils.R b/R/utils.R
@@ -31,13 +31,7 @@ fhx <- function(year, series, rec_type, metalist=list()) {
 #'
 #' @export
 make_rec_type <- function(x) {
-  possible_levels = 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",
-           "estimate")
+  possible_levels = rec_type_all
   stopifnot(x %in% possible_levels)  # TODO(brews): This could be make into a more clear error.
   factor(x, levels = possible_levels)
 }
@@ -213,45 +207,35 @@ delete <- function(x, s, yr) {
 find_recording <- function(x, injury_event) {
   # Use with: ddply(lgr2$rings, 'series', recorder_finder)
   x <- x[order(x$year), ]
-  recorder <- list("|" = "recorder_year",
-                    "U" = "unknown_fs",
-                    "D" = "dormant_fs",
-                    "E" = "early_fs",
-                    "M" = "middle_fs",
-                    "L" = "late_fs",
-                    "A" = "latewd_fs")
-  injury <- list("u" = "unknown_fi",
-                   "d" = "dormant_fi",
-                   "e" = "early_fi",
-                   "m" = "middle_fi",
-                   "l" = "late_fi",
-                   "a" = "latewd_fi")
-  scar <- list("U" = "unknown_fs",
-                   "D" = "dormant_fs",
-                   "E" = "early_fs",
-                   "M" = "middle_fs",
-                   "L" = "late_fs",
-                   "A" = "latewd_fs")
-  ends <- list("[" = "pith_year",
-               "]" = "bark_year",
-               "{" = "inner_year",
-               "}" = "outer_year")
+
+  recorder <- rec_type_recorder
+  injury <- rec_type_injury
+  scar <- rec_type_scar
+  ends <- rec_type_ends
+
   if (injury_event) {
     recorder <- c(recorder, injury)
   }
+
   rec <- subset(x, x$rec_type %in% recorder)$year
   inj <- subset(x, x$rec_type %in% injury)$year
   end <- subset(x, x$rec_type %in% ends)$year
+
   inj_dif <- diff(inj)
+
+  # "ends" and "injuries" only record when there is recording event in adjacent year
   active <- c(rec, intersect(rec - 1, end), intersect(rec + 1, end))
   active <- c(active, intersect(active - 1, inj), intersect(active + 1, inj)) # Really only need when injury_event = FALSE.
+
+  # recording-ness is communicated through injury events
   if (any(inj_dif == 1) & !injury_event) {
     for (i in which(inj_dif == 1)) {
       if (inj_dif[i] %in% active) {
         active <- c(inj_dif[i + 1], active)
       }
     }
   }
+
   data.frame(recording = union(rec, active))
 }
 
@@ -282,7 +266,7 @@ find_recording <- function(x, injury_event) {
 count_event_position <- function(x, injury_event=FALSE, position, groupby) {
   stopifnot(is.fhx(x))
 
-  possible_position = c("unknown", "dormant", "early", "middle", "late", "latewd")
+  possible_position <- c("unknown", "dormant", "early", "middle", "late", "latewd")
   if (missing(position))
     position <- possible_position
   stopifnot(all(position %in% possible_position))
@@ -345,22 +329,11 @@ yearly_recording <- function(x, injury_event=FALSE) {
 #' @export
 composite <- function(x, filter_prop=0.25, filter_min_rec=2, filter_min_events = 1, injury_event=FALSE, comp_name='COMP') {
   stopifnot(is.fhx(x))
-  injury <- list("u" = "unknown_fi",
-                 "d" = "dormant_fi",
-                 "e" = "early_fi",
-                 "m" = "middle_fi",
-                 "l" = "late_fi",
-                 "a" = "latewd_fi")
-  scar <- list("U" = "unknown_fs",
-               "D" = "dormant_fs",
-               "E" = "early_fs",
-               "M" = "middle_fs",
-               "L" = "late_fs",
-               "A" = "latewd_fs")
-  ends <- list("[" = "pith_year",
-               "]" = "bark_year",
-               "{" = "inner_year",
-               "}" = "outer_year")
+
+  injury <- rec_type_injury
+  scar <- rec_type_scar
+  ends <- rec_type_ends
+
   event <- scar
   if (injury_event) {
     event <- c(event, injury)
@@ -469,7 +442,7 @@ is.fhx <- function(x) {
 #'
 #' @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.
+#' @return `x` cast to 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}.

diff --git a/data-raw/sysdata.R b/data-raw/sysdata.R
@@ -0,0 +1,58 @@
+library(usethis)
+library(burnr)
+
+
+type_key <- list("?" = "estimate",  # My own creation for estimated years to pith.
+                "." = "null_year",
+                "|" = "recorder_year",
+                "U" = "unknown_fs",
+                "u" = "unknown_fi",
+                "D" = "dormant_fs",
+                "d" = "dormant_fi",
+                "E" = "early_fs",
+                "e" = "early_fi",
+                "M" = "middle_fs",
+                "m" = "middle_fi",
+                "L" = "late_fs",
+                "l" = "late_fi",
+                "A" = "latewd_fs",
+                "a" = "latewd_fi",
+                "[" = "pith_year",
+                "]" = "bark_year",
+                "{" = "inner_year",
+                "}" = "outer_year")
+
+rec_type_all <- unlist(type_key)
+# Has names() of the original, abbreviated FHX file event codes.
+
+rec_type_abrv <- names(rec_type_all)
+# Has names() of the rec_type levels we use for this package.
+names(rec_type_abrv) <- rec_type_all
+
+rec_type_recorder <- c("recorder_year",
+                       "unknown_fs",
+                       "dormant_fs",
+                       "early_fs",
+                       "middle_fs",
+                       "late_fs",
+                       "latewd_fs")
+rec_type_injury <- c("unknown_fi",
+                     "dormant_fi",
+                     "early_fi",
+                     "middle_fi",
+                     "late_fi",
+                     "latewd_fi")
+rec_type_scar <- c("unknown_fs",
+                   "dormant_fs",
+                   "early_fs",
+                   "middle_fs",
+                   "late_fs",
+                   "latewd_fs")
+rec_type_ends <- c("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,
+                  internal = TRUE, overwrite = TRUE)
diff --git a/man/abrv2rec_type.Rd b/man/abrv2rec_type.Rd
diff --git a/man/as.fhx.Rd b/man/as.fhx.Rd
diff --git a/man/rec_type2abrv.Rd b/man/rec_type2abrv.Rd
diff --git a/tests/testthat/test-io.R b/tests/testthat/test-io.R
@@ -718,4 +718,3 @@ test_that("list_filestrings() on basic FHX obj", {
   expect_equal(target[["body"]]$b1, c("[", ".", "]", "."))
   expect_equal(target[["body"]]$yr, seq(1998, 2001))
 })
-