Skip to content

Commit

Permalink
update
Browse files Browse the repository at this point in the history
  • Loading branch information
@joethorley
joethorley committed Feb 3, 2024
1 parent 8987cd0 commit 61013da
Show file tree
Hide file tree
Showing 3 changed files with 71 additions and 64 deletions.
50 changes: 28 additions & 22 deletions R/gsdd-cf.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,22 +5,18 @@
#' beginning of winter.
#' It is the accumulated thermal units (in C)
#' during the growing season based on the mean daily water temperature values.
#' Only GSDD values calculated using the default values should be considered
#' equivalent to those of Coleman and Fausch (2007).
#'
#' The GSDD is calculated across the longest consecutive sequence of non-missing
#' values which must be at least 184 elements in length otherwise a
#' missing value is returned.
#' If the time series includes missing values it is recommended that they are
#' If the vector includes missing values it is recommended that they are
#' replaced by estimates of the actual values using linear
#' interpolation (`[interpolate_numeric_vector()]`) or other predictive methods.
#' If the user removes the missing values then the returned GSDD value
#' will be less than the actual GSDD.
#'
#' Truncation occurs when the start and/or end
#' of the time series is part way through a growing season.
#' If the user chooses to ignore truncation then the returned value
#' will be less than the actual GSDD.
#'
#' By default the growing season is based on the interpretation of
#' By default the default values and implementation of the
#' growing season are based on the interpretation of
#' Coleman and Fausch (2007) who stated that
#'
#' We defined the start of the growing season as the
Expand All @@ -44,15 +40,20 @@
#' season with the `"biggest"` GSDD is selected.
#' Conversely in the case of multiple `"shortest"` seasons then the
#' candidate with the `"smallest"` GSDD is selected.
#'
#' Truncation occurs when the start and/or end
#' of the time series is part way through a growing season.
#' If the user chooses to ignore truncation then the returned value
#' will be less than the actual GSDD.
#'
#' @param x A numeric vector of the
#' mean daily water temperature values for the period
#' of interest in C. It must be consist of no more than
#' 366 values.
#' @param ignore_truncation A flag specifying whether to ignore truncation
#' of the mean daily water temperature vector
#' or a string of "start", "end", "none" or "both"
#' specifying which type of truncation to ignore.
#' or a string of "start", "end", "none" (equivalent to FALSE) or "both"
#' (equivalent to TRUE) specifying which type of truncation to ignore.
#' @param start_temp A positive real number of the average water temperature
#' at the start of the growing season in C.
#' @param end_temp A positive real number of the average water temperature
Expand All @@ -64,8 +65,7 @@
#' "longest", "shortest", "first" or "last" 'season' or the season with the
#' "biggest" or "smallest" GSDD. By default the returned value is the
#' sum of the GSDD values for "all" 'seasons'.
#' @param quiet A flag specifying whether to suppress warnings.
#'
#' @param msgs A flag specifying whether to provide messages.
#' @return A non-negative real number of the GSDD.
#' @export
#'
Expand All @@ -78,10 +78,10 @@ gsdd_cf <- function(x,
end_temp = 4,
window_width = 7,
pick = "all",
quiet = FALSE) {
msgs = TRUE) {
chk_numeric(x)
chk_vector(x)
chk_length(x, 0, 366)
chk_lte(length(x), 366)

chkor_vld(vld_flag(ignore_truncation), vld_string(ignore_truncation))
if (isTRUE(ignore_truncation)) {
Expand All @@ -103,13 +103,19 @@ gsdd_cf <- function(x,
chk_subset(
pick,
c("biggest", "smallest", "longest", "shortest", "first", "last", "all"))
chk_flag(quiet)
chk_flag(msgs)

if(length(x) < 184) {
if (msgs) {
msg("`The length of `x` must be at least 184. Returning `NA`.")
}
return(NA_real_)
}
x <- longest_run(x)
if(length(x) < 184 || anyNA(x)) {
if(msgs) {
msg("The length of the longest non-missing sequence in `x` must be at least 184. Returning `NA`.")
}
return(NA_real_)
}
# create rolling mean vector from x and window width
Expand All @@ -126,21 +132,21 @@ gsdd_cf <- function(x,
# if season starts on first day, ignore_truncation left
if (index_start[1] == 1L) {
truncated <- TRUE
if (!quiet) {
warning("Growing season truncated.")
}
if (ignore_truncation %in% c("none", "end")) {
if (msgs) {
msg("The growing season is truncated at the end of the sequence. Returning `NA`.")
}
return(NA_real_)
}
}
# pick which indices have values above and temp that begin runs
index_end <- index_begin_run(rollmean < end_temp)
# if season doesnt end ignore_truncation right
if (!length(index_end) || max(index_start) > max(index_end)) {
if (!truncated && !quiet) {
warning("Growing season truncated.")
}
if (ignore_truncation %in% c("none", "start")) {
if (msgs) {
msg("The growing season is truncated at the start of the sequence. Returning `NA`.")
}
return(NA_real_)
}
index_end <- c(index_end, length(rollmean))
Expand Down
27 changes: 14 additions & 13 deletions man/gsdd_cf.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

58 changes: 29 additions & 29 deletions tests/testthat/test-gsdd-cf.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,14 +17,14 @@ test_that("window_width must be odd", {
test_that("gsdd_cf returns NA when missing summer", {
x <- simulated_data$synthetic
x[85:320] <- NA_real_
expect_identical(gsdd_cf(x), NA_real_)
expect_identical(gsdd_cf(x, msgs = FALSE), NA_real_)
})

test_that("vector must not contain NA values", {
x <- simulated_data$synthetic
random_indices <- sample(seq_along(x), 40)
x[random_indices] <- NA
expect_identical(gsdd_cf(x), NA_real_)
expect_identical(gsdd_cf(x, msgs = FALSE), NA_real_)
})

test_that("gsdd_cf trims missing values", {
Expand All @@ -44,23 +44,23 @@ test_that("if max temp in vector is lower than start_temp the function return 0"
expect_identical(output, 0)
})

test_that("if end_temp is not reached, gsdd calculated to end of vector and warning is shown", {
test_that("if end_temp is not reached, gsdd calculated to end of vector and message is provided.", {
x <- simulated_data$synthetic
expect_warning(gsdd_cf(x, end_temp = -40, ))
expect_message(gsdd_cf(x, end_temp = -40), "The growing season is truncated at the start of the sequence. Returning `NA`.")
})

test_that("if end_temp is reached at end of vector x, indicies do not fall off the edge", {
x <- simulated_data$synthetic
gsdd <- gsdd_cf(x, end_temp = -4, quiet = TRUE, ignore_truncation = TRUE)
gsdd <- gsdd_cf(x, end_temp = -4, msgs = FALSE, ignore_truncation = TRUE)
expect_equal(gsdd, 3921.63308)
})

test_that("if start_temp is reached at start of vector x, indicies do not fall off the edge", {
x <- simulated_data$synthetic
x <- x[163:length(x)]
gsdd <- gsdd_cf(x, end_temp = 4, quiet = TRUE)
gsdd <- gsdd_cf(x, end_temp = 4, msgs = FALSE)
expect_equal(gsdd, NA_real_)
gsdd <- gsdd_cf(x, end_temp = 4, quiet = TRUE, ignore_truncation = TRUE)
gsdd <- gsdd_cf(x, end_temp = 4, msgs = FALSE, ignore_truncation = TRUE)
expect_equal(gsdd, 2687.98160174586)
})

Expand Down Expand Up @@ -100,63 +100,63 @@ test_that("Gets growth period with all GSDD.", {

test_that("Gets growth period with higher GSDD even though shorter period.", {
x <- c(rep(10, 50), rep(0, 255), rep(20, 40))
gsdd <- gsdd_cf(x, window_width = 3, start_temp = 9, end_temp = 9, quiet = TRUE)
gsdd <- gsdd_cf(x, window_width = 3, start_temp = 9, end_temp = 9, msgs = FALSE)
expect_equal(gsdd, NA_real_)
gsdd <- gsdd_cf(x,
window_width = 3, start_temp = 9, end_temp = 9, quiet = TRUE,
window_width = 3, start_temp = 9, end_temp = 9, msgs = FALSE,
ignore_truncation = TRUE, pick = "biggest"
)
expect_equal(gsdd, 800)
})

test_that("Gets growth period longest period.", {
x <- c(rep(10, 50), rep(0, 255), rep(20, 40))
gsdd <- gsdd_cf(x, window_width = 3, start_temp = 9, end_temp = 9, quiet = TRUE)
gsdd <- gsdd_cf(x, window_width = 3, start_temp = 9, end_temp = 9, msgs = FALSE)
expect_equal(gsdd, NA_real_)
gsdd <- gsdd_cf(x,
window_width = 3, start_temp = 9, end_temp = 9, quiet = TRUE,
window_width = 3, start_temp = 9, end_temp = 9, msgs = FALSE,
ignore_truncation = TRUE, pick = "longest"
)
expect_equal(gsdd, 500)
})

test_that("Gets growth period all gsdd.", {
x <- c(rep(10, 50), rep(0, 255), rep(20, 40))
gsdd <- gsdd_cf(x, window_width = 3, start_temp = 9, end_temp = 9, quiet = TRUE)
gsdd <- gsdd_cf(x, window_width = 3, start_temp = 9, end_temp = 9, msgs = FALSE)
expect_equal(gsdd, NA_real_)
gsdd <- gsdd_cf(x,
window_width = 3, start_temp = 9, end_temp = 9, quiet = TRUE,
window_width = 3, start_temp = 9, end_temp = 9, msgs = FALSE,
ignore_truncation = TRUE, pick = "all"
)
expect_equal(gsdd, 1300)
})

test_that("Gets growth period shortest", {
x <- c(rep(10, 50), rep(0, 255), rep(20, 40))
gsdd <- gsdd_cf(x, window_width = 3, start_temp = 9, end_temp = 9, quiet = TRUE)
gsdd <- gsdd_cf(x, window_width = 3, start_temp = 9, end_temp = 9, msgs = FALSE)
expect_equal(gsdd, NA_real_)
gsdd <- gsdd_cf(x,
window_width = 3, start_temp = 9, end_temp = 9, quiet = TRUE,
window_width = 3, start_temp = 9, end_temp = 9, msgs = FALSE,
ignore_truncation = TRUE, pick = "shortest"
)
expect_equal(gsdd, 800)
})

test_that("Gets growth period longest", {
x <- c(rep(10, 50), rep(0, 255), rep(20, 40))
gsdd <- gsdd_cf(x, window_width = 3, start_temp = 9, end_temp = 9, quiet = TRUE)
gsdd <- gsdd_cf(x, window_width = 3, start_temp = 9, end_temp = 9, msgs = FALSE)
expect_equal(gsdd, NA_real_)
gsdd <- gsdd_cf(x,
window_width = 3, start_temp = 9, end_temp = 9, quiet = TRUE,
window_width = 3, start_temp = 9, end_temp = 9, msgs = FALSE,
ignore_truncation = TRUE, pick = "longest"
)
expect_equal(gsdd, 500)
})

test_that("Gets growth gives warnings with truncation.", {
test_that("Gets growth gives messages with truncation.", {
x <- c(rep(10, 50), rep(0, 255), rep(20, 40))
expect_warning(expect_identical(gsdd_cf(x), NA_real_), "Growing season truncated\\.")
expect_warning(expect_identical(gsdd_cf(x, ignore_truncation = "start"), NA_real_), "Growing season truncated\\.")
expect_message(expect_identical(gsdd_cf(x), NA_real_), "The growing season is truncated at the end of the sequence. Returning `NA`.")
expect_message(expect_identical(gsdd_cf(x, ignore_truncation = "start"), NA_real_), "The growing season is truncated at the start of the sequence. Returning `NA`.")
})

test_that("Gets gsdd with single boiling day.", {
Expand Down Expand Up @@ -203,17 +203,17 @@ test_that("Gets with two weeks and 3 day window and smaller", {

test_that("Gets one week with end day after of 0", {
x <- c(rep(0, 180), rep(5.1, 7), rep(1, 0))
expect_equal(gsdd_cf(x, ignore_truncation = "end", quiet = TRUE), 5.1 * 7)
expect_equal(gsdd_cf(x, ignore_truncation = "end", msgs = FALSE), 5.1 * 7)
})

test_that("Gets one week with end day after of 1", {
x <- c(rep(0, 180), rep(5.1, 7), rep(1, 1))
expect_equal(gsdd_cf(x, ignore_truncation = "end", quiet = TRUE), 5.1 * 7 + 1)
expect_equal(gsdd_cf(x, ignore_truncation = "end", msgs = FALSE), 5.1 * 7 + 1)
})

test_that("Gets with two weeks and 3 day window and smaller", {
x <- c(rep(0, 180), rep(5.1, 7))
expect_equal(gsdd_cf(x, ignore_truncation = "end", quiet = TRUE), 5.1 * 7)
expect_equal(gsdd_cf(x, ignore_truncation = "end", msgs = FALSE), 5.1 * 7)
})

test_that("Gets triangle", {
Expand Down Expand Up @@ -304,8 +304,8 @@ test_that("Right truncated triangle", {
tibble::tibble(index = 1:length(x), x = x, ma = ma)
})

expect_equal(gsdd_cf(x, quiet = TRUE), NA_real_)
expect_equal(gsdd_cf(x, ignore_truncation = "end", quiet = TRUE), sum(x[15:length(x)]))
expect_equal(gsdd_cf(x, msgs = FALSE), NA_real_)
expect_equal(gsdd_cf(x, ignore_truncation = "end", msgs = FALSE), sum(x[15:length(x)]))
})

test_that("Left truncated triangle", {
Expand All @@ -320,20 +320,20 @@ test_that("Left truncated triangle", {
tibble::tibble(index = 1:length(x), x = x, ma = ma)
})

expect_equal(gsdd_cf(x, quiet = TRUE), NA_real_)
expect_equal(gsdd_cf(x, ignore_truncation = "start", quiet = TRUE), sum(x[0:25]))
expect_equal(gsdd_cf(x, msgs = FALSE), NA_real_)
expect_equal(gsdd_cf(x, ignore_truncation = "start", msgs = FALSE), sum(x[0:25]))
})

test_that("NA if less than 184 values after trimming trailing NAs", {
x <- c(rep(1,183), rep(NA,100))
expect_identical(gsdd_cf(x),NA_real_)
expect_message(expect_identical(gsdd_cf(x),NA_real_), "The length of the longest non-missing sequence in `x` must be at least 184. Returning `NA`.")
x <- c(rep(1,184), rep(NA,100))
expect_identical(gsdd_cf(x),0)
})

test_that("extracts longest non-missing sequence (not just trim tails)", {
x <- c(NA,1,NA,rep(1,183),NA,1,NA)
expect_identical(gsdd_cf(x),NA_real_)
expect_identical(gsdd_cf(x, msgs = FALSE),NA_real_)
x <- c(NA,1,NA,rep(1,184),NA,1,NA)
expect_identical(gsdd_cf(x),0)
})

0 comments on commit 61013da

Please sign in to comment.