Merge pull request #7 from poissonconsulting/f-complete

Added `complete = FALSE` argument to `gsdd_vctr()` and `gss_vctr()` to specify whether the vector of water temperatures represents the complete growing period.

R/gsdd-vctr.R

@@ -19,6 +19,7 @@ gsdd_vctr <- function(
     end_temp = 4,
     window_width = 7,
     pick = "all",
+    complete = FALSE,
     msgs = TRUE) {
   gss <- .gss_vctr(
     x, 
@@ -28,6 +29,7 @@ gsdd_vctr <- function(
     end_temp = end_temp,
     window_width = window_width,
     pick = pick,
+    complete = complete,
     msgs = msgs)
 
   if(vld_scalar(gss)) {

R/gss-vctr.R

@@ -6,6 +6,7 @@ gss_vctr <- function(
     end_temp = 4,
     window_width = 7,
     pick = "all",
+    complete = FALSE,
     msgs = TRUE,
     .rollmean = FALSE) {
   gss <- .gss_vctr(
@@ -16,6 +17,7 @@ gss_vctr <- function(
     end_temp = end_temp,
     window_width = window_width, 
     pick = pick,
+    complete = complete,
     msgs = msgs,
     .rollmean = .rollmean)
 

R/internal.R

@@ -5,6 +5,7 @@
                       end_temp,
                       window_width,
                       pick,
+                      complete,
                       msgs,
                       .rollmean = FALSE) {
   chk_numeric(x)
@@ -32,7 +33,7 @@
   chk_subset(
     pick, 
     c("biggest", "smallest", "longest", "shortest", "first", "last", "all"))
-
+  chk_flag(complete)
   chk_flag(msgs)
   chk_flag(.rollmean)
 
@@ -43,6 +44,8 @@
     return(NA_real_)
   }
   run <- longest_run(x)
+  complete_start <- complete & run[1] == 1L
+  complete_end <- complete & run[length(run)] == length(x)
   x <- x[run]
   length_x <- length(x)
   if(length_x < min_length || anyNA(x)) {
@@ -69,7 +72,7 @@
   }
   # if season starts on first day, ignore_truncation left
   if (start_index[1] == 1L) {
-    if (ignore_truncation %in% c("none", "end")) {
+    if (!complete_start && ignore_truncation %in% c("none", "end")) {
       if (msgs) {
         msg("The growing season is truncated at the start of the sequence.")
       }
@@ -80,7 +83,7 @@
   end_index <- index_begin_run(rollmean < end_temp)
   # if season doesnt end ignore_truncation right
   if (!length(end_index) || max(start_index) > max(end_index)) {
-    if (ignore_truncation %in% c("none", "start")) {
+    if (!complete_end && ignore_truncation %in% c("none", "start")) {
       if (msgs) {
         msg("The growing season is truncated at the end of the sequence.")
       }
@@ -106,9 +109,9 @@
       end_index = .data$end_index + (as.integer(window_width) - 1L),
       ndays = .data$end_index - .data$start_index + 1L,
       truncation = dplyr::case_when(
-        start_index == 1L & end_index == length_x & rollmean[length_rollmean] > end_temp ~ "both",
-        start_index == 1L ~ "start",
-        end_index == length_x & rollmean[length_rollmean] > end_temp ~ "end",
+        start_index == 1L & end_index == length_x & rollmean[length_rollmean] > end_temp & !complete_start & !complete_end ~ "both",
+        start_index == 1L & !complete_start ~ "start",
+        end_index == length_x & rollmean[length_rollmean] > end_temp & !complete_end ~ "end",
         TRUE ~ "none")
     ) |>
     dplyr::mutate(gsdd = purrr::map2_dbl(
@@ -208,6 +211,7 @@ complete_dates <- function(x, start_date, end_date) {
       end_temp = 4, 
       window_width = window_width, 
       msgs = FALSE,
+      complete = TRUE,
       .rollmean = TRUE), .keep = TRUE)
 
   if(!nrow(x)) {
@@ -265,7 +269,14 @@ complete_dates <- function(x, start_date, end_date) {
     x <- x |>
       dplyr::summarise(gsdd = gsdd_vctr(
         .data$temperature,     
-        ignore_truncation = ignore_truncation, min_length = min_length, start_temp, end_temp = end_temp, window_width = window_width, pick = pick, msgs = msgs), .groups = "keep") |>
+        ignore_truncation = ignore_truncation, 
+        min_length = min_length, 
+        start_temp = start_temp, 
+        end_temp = end_temp, 
+        window_width = window_width, 
+        pick = pick, 
+        complete = TRUE,
+        msgs = msgs), .groups = "keep") |>
       dplyr::ungroup()
 
     return(x)
@@ -281,6 +292,7 @@ complete_dates <- function(x, start_date, end_date) {
         end_temp = end_temp, 
         window_width = window_width, 
         pick = pick,
+        complete = TRUE,
         msgs = msgs), .keep = TRUE)
 
     if(!nrow(x)) {

R/params.R

@@ -1,6 +1,11 @@
 #' Parameters for functions
 #'
 #' Descriptions of the parameters for functions
+#' @param complete A flag specifying whether the vector of water temperatures 
+#' represents the complete possible growing period (by default FALSE). 
+#' If TRUE a growing season is not considered to be truncated 
+#' at the start and/or end if the water temperature is above the threshold
+#' at the start and/or ends.
 #' @param end_date A Date scalar of the last date 
 #' within each year to consider (the year is ignored).
 #' @param end_temp A positive real number of the average water temperature

tests/testthat/_snaps/gsdd.md

@@ -36,7 +36,7 @@
       # A tibble: 1 x 2
          year  gsdd
         <int> <dbl>
-      1  2019  545.
+      1  2019  529.
 
 # gsdd ignore truncation tiny window
 

tests/testthat/_snaps/gss.md

@@ -62,7 +62,7 @@
       # Groups:   year [1]
          year start_dayte end_dayte   gsdd truncation
         <int> <date>      <date>     <dbl> <chr>     
-      1  2019 1971-03-20  1971-11-07 3899. start     
+      1  2019 1971-03-20  1971-11-07 3899. none      
 
 # gss preserves if shift before leap year
 
@@ -104,6 +104,17 @@
       # i 5 variables: year <int>, start_dayte <date>, end_dayte <date>, gsdd <dbl>,
       #   truncation <chr>
 
+# gss works shortened truncated
+
+    Code
+      gss
+    Output
+      # A tibble: 1 x 5
+      # Groups:   year [1]
+         year start_dayte end_dayte   gsdd truncation
+        <int> <date>      <date>     <dbl> <chr>     
+      1  2019 1971-03-20  1971-09-28 3580. end       
+
 # gss NA if stops before
 
     Code
@@ -257,7 +268,7 @@
       # Groups:   year [1]
          year start_dayte end_dayte   gsdd truncation
         <int> <date>      <date>     <dbl> <chr>     
-      1  2019 1971-03-01  1971-06-04   742 start     
+      1  2019 1971-03-02  1971-06-04   736 start     
       2  2019 1971-07-15  1971-09-03   800 none      
 
 # gss truncation end
@@ -270,7 +281,7 @@
          year start_dayte end_dayte   gsdd truncation
         <int> <date>      <date>     <dbl> <chr>     
       1  2019 1971-04-08  1971-06-04   500 none      
-      2  2019 1971-07-15  1971-11-30  1255 end       
+      2  2019 1971-07-15  1971-11-29  1250 end       
 
 # gss truncation both ends
 
@@ -281,8 +292,8 @@
       # Groups:   year [1]
          year start_dayte end_dayte   gsdd truncation
         <int> <date>      <date>     <dbl> <chr>     
-      1  2019 1971-03-01  1971-06-04   742 start     
-      2  2019 1971-07-15  1971-11-30  1255 end       
+      1  2019 1971-03-02  1971-06-04   736 start     
+      2  2019 1971-07-15  1971-11-29  1250 end       
 
 # gss truncation all
 
@@ -293,7 +304,7 @@
       # Groups:   year [1]
          year start_dayte end_dayte   gsdd truncation
         <int> <date>      <date>     <dbl> <chr>     
-      1  2019 1971-03-01  1971-11-30  1650 both      
+      1  2019 1971-03-02  1971-11-29  1638 both      
 
 # gss not shift
 
@@ -306,3 +317,23 @@
         <int> <date>      <date>     <dbl> <chr>     
       1  2019 1971-06-08  1971-09-29  738. none      
 
+# gss above from start to finish
+
+    Code
+      gss
+    Output
+      # A tibble: 1 x 5
+      # Groups:   year [1]
+         year start_dayte end_dayte   gsdd truncation
+        <int> <date>      <date>     <dbl> <chr>     
+      1  2019 1971-03-01  1971-11-30  1650 none      
+
+# gss truncated if missing
+
+    Code
+      gss
+    Output
+      # A tibble: 0 x 5
+      # i 5 variables: year <int>, start_dayte <date>, end_dayte <date>, gsdd <dbl>,
+      #   truncation <chr>
+

tests/testthat/test-gsdd.R

@@ -22,15 +22,19 @@ test_that("gsdd NA if earlier truncation", {
 })
 
 test_that("gsdd NA if truncated", {
-  gsdd <- gsdd(temperature_data, start_date = as.Date("1972-05-01"), end_date = as.Date("1972-05-30"),
+  data <- temperature_data 
+  data <- data[data$date >= as.Date("2019-05-02"),]
+  gsdd <- gsdd(data, start_date = as.Date("1972-05-01"), end_date = as.Date("1972-05-30"),
                        msgs = FALSE)
   expect_snapshot({
     gsdd
   })
 })
 
 test_that("gsdd ignore truncation", {
-  gsdd <- gsdd(temperature_data, start_date = as.Date("1972-05-01"), end_date = as.Date("1972-05-30"),
+  data <- temperature_data 
+  data <- data[data$date >= as.Date("2019-05-02"),]
+  gsdd <- gsdd(data, start_date = as.Date("1972-05-01"), end_date = as.Date("1972-05-30"),
                        msgs = FALSE, ignore_truncation = TRUE)
   expect_snapshot({
     gsdd

tests/testthat/test-gss.R

@@ -73,13 +73,24 @@ test_that("gss works", {
 })
 
 test_that("gss works shortened", {
-  expect_message(gss <- gss(temperature_data, min_length = 100, end_date = as.Date("1972-09-29")),
+  data <- temperature_data
+  data <- data[data$date <= as.Date("2019-09-28"),]
+  expect_message(gss <- gss(data, min_length = 100, end_date = as.Date("1972-09-29")),
                  "The growing season is truncated at the end of the sequence.")
   expect_snapshot({
     gss
   })
 })
 
+test_that("gss works shortened truncated", {
+  data <- temperature_data
+  data <- data[data$date <= as.Date("2019-09-28"),]
+  gss <- gss(data, min_length = 100, end_date = as.Date("1972-09-29"), ignore_truncation = "end")
+  expect_snapshot({
+    gss
+  })
+})
+
 test_that("gss NA if stops before", {
   data <- temperature_data
   data <- data[data$date < as.Date("2019-09-30"),]
@@ -200,6 +211,7 @@ test_that("gss truncation start", {
   data <- gsdd::temperature_data
   data$temperature <- data$temperature2
   data$temperature[data$date <= as.Date("2019-04-11")] <- 6
+  data <- data[data$date >= as.Date("2019-03-02"),]
   gss <- gss(data, ignore_truncation =TRUE)
   expect_snapshot({
     gss
@@ -210,6 +222,7 @@ test_that("gss truncation end", {
   data <- gsdd::temperature_data
   data$temperature <- data$temperature2
   data$temperature[data$date >= as.Date("2019-08-28")] <- 5
+  data <- data[data$date <= as.Date("2019-11-29"),]
   gss <- gss(data, ignore_truncation =TRUE)
   expect_snapshot({
     gss
@@ -221,7 +234,8 @@ test_that("gss truncation both ends", {
   data$temperature <- data$temperature2
   data$temperature[data$date <= as.Date("2019-04-11")] <- 6
   data$temperature[data$date >= as.Date("2019-08-28")] <- 5
-  gss <- gss(data, ignore_truncation =TRUE)
+  data <- data[data$date >= as.Date("2019-03-02") & data$date <= as.Date("2019-11-29"),]
+  gss <- gss(data, min_length = 100, ignore_truncation =TRUE)
   expect_snapshot({
     gss
   })
@@ -231,7 +245,8 @@ test_that("gss truncation all", {
   data <- gsdd::temperature_data
   data$temperature <- data$temperature2
   data$temperature <- 6
-  gss <- gss(data, ignore_truncation =TRUE)
+  data <- data[data$date >= as.Date("2019-03-02") & data$date <= as.Date("2019-11-29"),]
+  gss <- gss(data, min_length = 100, ignore_truncation =TRUE)
   expect_snapshot({
     gss
   })
@@ -323,3 +338,22 @@ test_that("gss not shift", {
 
   gss_plot(data, min_length = 60)
 })
+
+test_that("gss above from start to finish", {
+  data <- gsdd::temperature_data
+  data$temperature <- 6
+  gss <- gss(data)
+  expect_snapshot({
+    gss
+  })
+})
+
+test_that("gss truncated if missing", {
+  data <- gsdd::temperature_data
+  data <- data[data$date >= as.Date("2019-03-02"),]
+  data$temperature <- 6
+  expect_message(gss <- gss(data), "The growing season is truncated at the start of the sequence.")
+  expect_snapshot({
+    gss
+  })
+})