Merge pull request #162 from chguiterman/master

Improving test coverage, doi badge, fix read_fhx blank space bug
ltrr-arizona-edu · Jul 3, 2020 · cbba0dc · cbba0dc
2 parents 0cb419d + b18414a
commit cbba0dc
Show file tree

Hide file tree

Showing 9 changed files with 60 additions and 2 deletions.
diff --git a/R/io.R b/R/io.R
@@ -123,7 +123,7 @@ read_fhx <- function(fname, encoding, text) {
                                  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 <- fl_body_melt[! fl_body_melt$rec_type %in% c(".", "\032"), ]
   fl_body_melt$rec_type <- vapply(fl_body_melt$rec_type, abrv2rec_type, "") # nolint
   fl_body_melt$rec_type <- make_rec_type(fl_body_melt$rec_type)
   f <- fhx(

diff --git a/R/utils.R b/R/utils.R
@@ -368,7 +368,7 @@ find_recording <- function(x, injury_event=FALSE) {
 #' @return A data frame with a row for each continuous recording segment, and
 #'   columns 'series', 'first', 'last', 'rec_type'.
 #'
-#' @example
+#' @examples
 #' data(pgm)
 #' get_rec_tbl(pgm, injury_event = TRUE)
 #'

diff --git a/README.Rmd b/README.Rmd
@@ -20,6 +20,8 @@ knitr::opts_chunk$set(
 [![Build Status](https://travis-ci.org/ltrr-arizona-edu/burnr.svg?branch=master)](https://travis-ci.org/ltrr-arizona-edu/burnr)
 [![Coverage Status](https://coveralls.io/repos/github/ltrr-arizona-edu/burnr/badge.svg?branch=master)](https://coveralls.io/github/ltrr-arizona-edu/burnr?branch=master)
 [![downloads](https://cranlogs.r-pkg.org/badges/burnr)](https://cran.r-project.org/package=burnr)
+[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.1134832.svg)](https://doi.org/10.5281/zenodo.1134832)
+
 <!-- badges: end -->
 
 Basic tools to analyze forest fire history data (e.g. FHX) in R. This is designed for power users and projects with special needs.

diff --git a/README.md b/README.md
@@ -11,6 +11,8 @@ Status](https://travis-ci.org/ltrr-arizona-edu/burnr.svg?branch=master)](https:/
 [![Coverage
 Status](https://coveralls.io/repos/github/ltrr-arizona-edu/burnr/badge.svg?branch=master)](https://coveralls.io/github/ltrr-arizona-edu/burnr?branch=master)
 [![downloads](https://cranlogs.r-pkg.org/badges/burnr)](https://cran.r-project.org/package=burnr)
+[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.1134832.svg)](https://doi.org/10.5281/zenodo.1134832)
+
 <!-- badges: end -->
 
 Basic tools to analyze forest fire history data (e.g. FHX) in R. This is

diff --git a/man/figures/README-example-1.png b/man/figures/README-example-1.png
diff --git a/tests/testthat/test-intervals.R b/tests/testthat/test-intervals.R
@@ -31,3 +31,14 @@ test_that("quantile.intervals() basic cases", {
     tolerance = 1e-3
   )
 })
+
+test_that("The intervals object prints", {
+  prnt_int <- capture_output(print(TEST_INTER))
+  expect_equal(nchar(prnt_int), 771)
+})
+
+test_that("Plotting intervals works", {
+  p <- plot(TEST_INTER)
+  expect_is(p, "ggplot")
+})
+
diff --git a/tests/testthat/test-io.R b/tests/testthat/test-io.R
@@ -729,3 +729,26 @@ test_that("list_filestrings() on basic FHX obj", {
   expect_equal(target[["body"]]$b1, c("[", ".", "]", "."))
   expect_equal(target[["body"]]$yr, seq(1998, 2001))
 })
+
+test_that("read_fhx() catches errors in files", {
+  BAD_FILE <- TEST_LGR2[-35]
+  expect_error(read_fhx(BAD_FILE))
+})
+
+test_that("violates_canon() warns users of new seasonality designations", {
+  series <- "ABC123"
+  year <- 1950:1952
+  rec_type <- c("pith_year", "falldormant_fs", "bark_year")
+  df <- fhx(year, series, rec_type)
+  tempFile <- file.path(tempdir(), "temp.fhx")
+  expect_warning(write_fhx(df, tempFile))
+  unlink(tempFile)
+})
+
+# https://github.com/awalker89/openxlsx/blob/master/tests/testthat/test-write_data_to_sheetData.R
+test_that("Write a .fhx file", {
+  tempFile <- file.path(tempdir(), "temp.fhx")
+  write_fhx(TEST_FHX, tempFile)
+  unlink(tempFile)
+})
+
diff --git a/tests/testthat/test-sea.R b/tests/testthat/test-sea.R
@@ -44,3 +44,13 @@ test_that("Check sea departure data.frame", {
   expect_equal(SEA_TEST$departure$upper_99_perc, goal_upper99)
   expect_equal(SEA_TEST$departure$lower_99_perc, goal_lower99)
 })
+
+test_that("Plotting sea output works", {
+  p <- plot(SEA_TEST)
+  expect_is(p, "ggplot")
+})
+
+test_that("The sea object prints", {
+  prnt_sea <- capture_output(print(SEA_TEST))
+  expect_equal(prnt_sea, "\tSuperposed Epoch Analysis\n\t=========================\n lag upper95 lower95 upper99 lower99 departure sig\n  -6   1.032  -1.006   1.333  -1.267    -0.283    \n  -5   1.014  -1.014   1.415  -1.333     0.608    \n  -4   0.966  -1.054   1.179  -1.337    -0.148    \n  -3   0.996  -1.049   1.331  -1.407     0.997   .\n  -2   0.972  -1.061   1.174  -1.311     1.234   *\n  -1   0.977  -1.040   1.169  -1.329     0.204    \n   0   0.965  -0.957   1.341  -1.333    -2.156   *\n   1   1.015  -0.995   1.427  -1.332    -0.090    \n   2   1.015  -1.025   1.508  -1.310    -0.505    \n   3   0.932  -1.020   1.232  -1.342     0.299    \n   4   1.013  -1.045   1.386  -1.364     0.283    \n---\nSignif. codes: 0.01 '*' 0.05 '.'")
+})
diff --git a/tests/testthat/test-stats.R b/tests/testthat/test-stats.R
@@ -130,3 +130,13 @@ test_that("percent scarred works with injuries", {
     goal_1806_percent_scarred
   )
 })
+
+test_that("Summary output is consistent", {
+  lgr_summ <- unlist(summary(lgr2))
+  target <- c("number_series" = 26,
+              "first_year" = 1366,
+              "last_year" = 2012,
+              "number_scars" = 9,
+              "number_injuries" = 6)
+  expect_equal(lgr_summ, target)
+})