Merge pull request #9 from poissonconsulting/atu

- Added `date_atus()` to determine date when ATUs reached.

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+export(date_atus)
 export(gdd)
 export(gsdd)
 export(gsdd_vctr)

R/atu-index.R

@@ -0,0 +1,15 @@
+.atu_index <- function(
+    x,
+    date,
+    atus,
+    msgs = TRUE) {
+
+  x <- pmax(x, 0)
+  x <- cumsum(x)
+  wch <- which(x >= atus)
+  if(!length(wch)) {
+    tibble::tibble(end_date = dttr2::NA_Date_, atus = NA_real_)
+  }
+  index <- wch[1]
+  tibble::tibble(end_date = date[index], atus = x[index])
+}

R/date-atus.R

@@ -0,0 +1,60 @@
+#' Calculate Date of Accumulated Thermal Units (ATUs)
+#' 
+#' Calculates the date on which a specified number of Accumulated Thermal Units (ATUs)
+#' are exceeded.
+#' 
+#' @inheritParams params
+#' @return A tibble with four columns `year`, `start_date`, `end_date` and `atus`.
+#' @export
+#'
+#' @examples
+#' date_atus(gsdd::temperature_data)
+date_atus <- function(
+    x,
+    atus = 600,
+    start_date = as.Date("1972-03-01"),
+    msgs = TRUE) {
+
+  check_data(x, list(date = dttr2::dtt_date("1970-01-01"), temperature = c(1, NA)))
+  chk_date(start_date)
+  chk_number(atus)
+  chk_gt(atus)
+
+  end_date <- start_date + 364L
+
+  end_dayte <- dttr2::dtt_dayte(end_date, start_date)
+  start_dayte <- dttr2::dtt_dayte(start_date, start_date)
+
+  x <- x |>
+    dplyr::mutate(
+      date = dttr2::dtt_date(.data$date)) |>
+    check_key("date", x_name = "x") |>
+    dplyr::arrange(.data$date)
+
+  if(!nrow(x)) {
+    return(tibble::tibble(
+      year = integer(), 
+      start_date = as.Date(integer()), 
+      end_date = as.Date(integer()), 
+      atus = numeric()))
+  }
+
+  x <- x |>
+    dplyr::mutate(
+      year = dttr2::dtt_study_year(.data$date, start = start_date),
+      year = stringr::str_extract(.data$year, "^\\d{4,4}"),
+      year = as.integer(.data$year)) |>
+    dplyr::group_by(.data$year) |>
+    dplyr::group_modify(~complete_dates(.x, start_date, end_date)) 
+
+  x <- x |>
+    dplyr::group_modify(~.atu_index(
+      .x$temperature,
+      .x$date,
+      atus = atus,
+      msgs = msgs), .keep = TRUE) |>
+    dplyr::mutate(end_date = dttr2::dtt_dayte(end_date, start_date),
+                  start_date = start_dayte) |>
+    dplyr::select(c("year", "start_date", "end_date", "atus"))                  
+  x
+}

R/params.R

@@ -1,6 +1,7 @@
 #' Parameters for functions
 #'
 #' Descriptions of the parameters for functions
+#' @param atus A positive number of the accumulated thermal units to exceed.
 #' @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 

tests/testthat/_snaps/date-atus.md

@@ -0,0 +1,156 @@
+# date_atus works
+
+    Code
+      date_atus
+    Output
+      # A tibble: 2 x 4
+      # Groups:   year [2]
+         year start_date end_date    atus
+        <int> <date>     <date>     <dbl>
+      1  2018 1971-03-01 NA           NA 
+      2  2019 1971-03-01 1971-05-11  617.
+
+# date_atus start year independent
+
+    Code
+      date_atus
+    Output
+      # A tibble: 2 x 4
+      # Groups:   year [2]
+         year start_date end_date    atus
+        <int> <date>     <date>     <dbl>
+      1  2018 1971-03-01 NA           NA 
+      2  2019 1971-03-01 1971-05-11  617.
+
+# date_atus changes if shift start date
+
+    Code
+      date_atus
+    Output
+      # A tibble: 2 x 4
+      # Groups:   year [2]
+         year start_date end_date    atus
+        <int> <date>     <date>     <dbl>
+      1  2018 1972-02-01 NA           NA 
+      2  2019 1972-02-01 1972-05-10  601.
+
+# date_atus shift before leap year
+
+    Code
+      date_atus
+    Output
+      # A tibble: 2 x 4
+      # Groups:   year [2]
+         year start_date end_date    atus
+        <int> <date>     <date>     <dbl>
+      1  2018 1972-02-28 NA           NA 
+      2  2019 1972-02-28 1972-05-10  600.
+
+# date_atus shift after leap year
+
+    Code
+      date_atus
+    Output
+      # A tibble: 2 x 4
+      # Groups:   year [2]
+         year start_date end_date    atus
+        <int> <date>     <date>     <dbl>
+      1  2018 1971-03-01 NA           NA 
+      2  2019 1971-03-01 1971-05-11  617.
+
+# date_atus change atu and date
+
+    Code
+      date_atus
+    Output
+      # A tibble: 1 x 4
+      # Groups:   year [1]
+         year start_date end_date    atus
+        <int> <date>     <date>     <dbl>
+      1  2019 1972-01-01 1972-04-20  304.
+
+# date_atus set negative to 0
+
+    Code
+      date_atus
+    Output
+      # A tibble: 1 x 4
+      # Groups:   year [1]
+         year start_date end_date    atus
+        <int> <date>     <date>     <dbl>
+      1  2019 1972-01-01 1972-04-20  304.
+
+# date_atus NA if missing
+
+    Code
+      date_atus
+    Output
+      # A tibble: 1 x 4
+      # Groups:   year [1]
+         year start_date end_date  atus
+        <int> <date>     <date>   <dbl>
+      1  2019 1972-01-01 NA          NA
+
+# date_atus not NA if after
+
+    Code
+      date_atus
+    Output
+      # A tibble: 1 x 4
+      # Groups:   year [1]
+         year start_date end_date    atus
+        <int> <date>     <date>     <dbl>
+      1  2019 1972-01-01 1972-04-20  304.
+
+# date_atus but NA if on
+
+    Code
+      date_atus
+    Output
+      # A tibble: 1 x 4
+      # Groups:   year [1]
+         year start_date end_date  atus
+        <int> <date>     <date>   <dbl>
+      1  2019 1972-01-01 NA          NA
+
+# date_atus no rows if no data
+
+    Code
+      date_atus
+    Output
+      # A tibble: 0 x 4
+      # i 4 variables: year <int>, start_date <date>, end_date <date>, atus <dbl>
+
+# date_atus NA if data set starts after
+
+    Code
+      date_atus
+    Output
+      # A tibble: 1 x 4
+      # Groups:   year [1]
+         year start_date end_date  atus
+        <int> <date>     <date>   <dbl>
+      1  2019 1972-01-01 NA          NA
+
+# date_atus not NA if data set starts after
+
+    Code
+      date_atus
+    Output
+      # A tibble: 1 x 4
+      # Groups:   year [1]
+         year start_date end_date    atus
+        <int> <date>     <date>     <dbl>
+      1  2019 1972-01-01 1972-04-20  304.
+
+# date_atus NA if not enough data to reach
+
+    Code
+      date_atus
+    Output
+      # A tibble: 1 x 4
+      # Groups:   year [1]
+         year start_date end_date  atus
+        <int> <date>     <date>   <dbl>
+      1  2019 1972-01-01 NA          NA
+