Closes #2146 Fix Time Imputation Flag (#2195)

* #2146 Fix Time Imputation Flag * #2146 check templates error * #2146 replace do.call * Replace function short hand with function * Update changelog --------- Co-authored-by: Ben Straub <[email protected]> Co-authored-by: Daniel Sjoberg <[email protected]>
pharmaverse · Nov 6, 2023 · 89a26ab · 89a26ab
1 parent 4fd22ce
commit 89a26ab
Show file tree

Hide file tree

Showing 6 changed files with 69 additions and 23 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -201,12 +201,15 @@ importFrom(lubridate,date)
 importFrom(lubridate,days)
 importFrom(lubridate,duration)
 importFrom(lubridate,floor_date)
+importFrom(lubridate,hour)
 importFrom(lubridate,hours)
 importFrom(lubridate,is.Date)
 importFrom(lubridate,is.POSIXct)
 importFrom(lubridate,is.instant)
+importFrom(lubridate,minute)
 importFrom(lubridate,minutes)
 importFrom(lubridate,rollback)
+importFrom(lubridate,second)
 importFrom(lubridate,time_length)
 importFrom(lubridate,weeks)
 importFrom(lubridate,years)
@@ -220,6 +223,7 @@ importFrom(purrr,keep)
 importFrom(purrr,map)
 importFrom(purrr,map2)
 importFrom(purrr,map_chr)
+importFrom(purrr,map_dbl)
 importFrom(purrr,map_if)
 importFrom(purrr,map_lgl)
 importFrom(purrr,modify_at)
@@ -244,6 +248,7 @@ importFrom(rlang,current_env)
 importFrom(rlang,enexpr)
 importFrom(rlang,eval_bare)
 importFrom(rlang,eval_tidy)
+importFrom(rlang,exec)
 importFrom(rlang,expr)
 importFrom(rlang,expr_interp)
 importFrom(rlang,expr_label)

diff --git a/NEWS.md b/NEWS.md
@@ -4,6 +4,10 @@
 
 ## Updates of Existing Functions
 
+- Fixed a bug in `compute_tmf()` where the time imputation flag was being incorrectly
+populated when any of the existing time components (hour, minute and/or second) of the date
+character vector (`'--DTC'`), was imputed. (#2146)
+
 - `derive_extreme_records()`, `derive_var_extreme_flag()`,`derive_vars_joined()` and `derive_vars_merged()` were enhanced with the arguments `true_value` and `false_value` to align with preexisting functions that had similar functionality (#2125)
 
 - `restrict_derivation()` now allows `{dplyr}` functions like `mutate` in the

diff --git a/R/admiral-package.R b/R/admiral-package.R
@@ -11,16 +11,17 @@
 #'   call2 caller_env call_name current_env .data enexpr eval_bare eval_tidy
 #'   expr expr_interp expr_label exprs f_lhs f_rhs inform is_call is_expression
 #'   is_missing new_formula parse_expr parse_exprs set_names sym syms type_of
-#'   warn as_data_mask list2
+#'   warn as_data_mask list2 exec
 #' @importFrom utils capture.output str file.edit
 #' @importFrom purrr map map2 map_chr map_lgl reduce walk keep map_if transpose
-#'             flatten every modify_at modify_if reduce compose pmap
+#'             flatten every modify_at modify_if reduce compose pmap map_dbl
 #' @importFrom stringr str_c str_count str_detect str_extract str_glue
 #'   str_length str_locate str_locate_all str_match str_remove str_remove_all
 #'   str_replace str_replace_all str_split str_starts str_sub str_subset
 #'   str_trim str_to_lower str_to_title str_to_upper
 #' @importFrom lubridate as_datetime ceiling_date date days duration floor_date is.Date is.instant
-#'             rollback time_length %--% ymd ymd_hms weeks years hours minutes is.POSIXct
+#'             rollback time_length %--% ymd ymd_hms weeks years hours minutes is.POSIXct hour
+#'             minute second
 #' @importFrom tidyr crossing drop_na fill nest pivot_longer pivot_wider unnest
 #' @importFrom tidyselect all_of any_of contains matches vars_select
 #' @importFrom hms as_hms

diff --git a/R/derive_date_vars.R b/R/derive_date_vars.R
@@ -1207,25 +1207,46 @@ compute_dtf <- function(dtc, dt) {
 #' @export
 #'
 #' @examples
-#' compute_tmf(dtc = "2019-07-18T15:25", dtm = as.POSIXct("2019-07-18T15:25:00"))
-#' compute_tmf(dtc = "2019-07-18T15", dtm = as.POSIXct("2019-07-18T15:25:00"))
-#' compute_tmf(dtc = "2019-07-18", dtm = as.POSIXct("2019-07-18"))
+#' library(lubridate)
+#'
+#' compute_tmf(dtc = "2019-07-18T15:25", dtm = ymd_hms("2019-07-18T15:25:00"))
+#' compute_tmf(dtc = "2019-07-18T15", dtm = ymd_hms("2019-07-18T15:25:00"))
+#' compute_tmf(dtc = "2019-07-18", dtm = ymd("2019-07-18"))
+#' compute_tmf(dtc = "2022-05--T00:00", dtm = ymd_hms("2022-05-15T23:59:59"))
+#' compute_tmf(dtc = "2022-05--T23:00", dtm = ymd_hms("2022-05-15T23:59:59"))
+#' compute_tmf(dtc = "2022-05--T23:59:00", dtm = ymd_hms("2022-05-15T23:59:59"))
+#'
 compute_tmf <- function(dtc,
                         dtm,
                         ignore_seconds_flag = FALSE) {
   assert_date_vector(dtm)
   assert_character_vector(dtc)
   assert_logical_scalar(ignore_seconds_flag)
 
+  valid_dtc <- is_valid_dtc(dtc)
+  warn_if_invalid_dtc(dtc, valid_dtc)
+
   partial <- get_partialdatetime(dtc)
   highest_miss <- convert_blanks_to_na(vector("character", length(dtc)))
-  for (c in c("hour", "minute", "second")) {
+
+  # concatenate lubridate functions: `hour()`, `minute()`, `second()` to map over dtm input
+  hms <- c("hour", "minute", "second")
+
+  # extract hour, minute, second over each value of dtm and put into a list time_part
+  time_part <-
+    map(set_names(hms), function(y) map_dbl(dtm, function(x) exec(y, x)))
+
+  for (c in hms) {
     highest_miss <-
-      if_else(is.na(partial[[c]]) & is.na(highest_miss), c, highest_miss)
+      if_else((is.na(partial[[c]]) & is.na(highest_miss)) |
+        (
+          !is.na(partial[[c]]) &
+            is.na(highest_miss) & as.numeric(partial[[c]]) != time_part[[c]]
+        ),
+      c,
+      highest_miss
+      )
   }
-  is_na <- is.na(dtm)
-  valid_dtc <- is_valid_dtc(dtc)
-  warn_if_invalid_dtc(dtc, valid_dtc)
 
   map <- c(
     hour = "H",

diff --git a/man/compute_tmf.Rd b/man/compute_tmf.Rd
diff --git a/tests/testthat/test-derive_date_vars.R b/tests/testthat/test-derive_date_vars.R
@@ -587,20 +587,26 @@ test_that("compute_tmf Test 30: compute TMF", {
     "2003-12-15T-:15:18",
     "2003-12-15T13:-:19",
     "2020-07--T00:00",
-    "2020-07--T00:00:00"
+    "2020-07--T00:00:00",
+    "2022-05--T00:00",
+    "2022-05--T23:00",
+    "2022-05--T23:59:00"
   )
   input_dtm <- c(
-    as.POSIXct("2019-07-18T15:25:52"),
-    as.POSIXct("2019-07-18T15:25:00"),
-    as.POSIXct("2019-07-18T15:00:00"),
+    ymd_hms("2019-07-18T15:25:52"),
+    ymd_hms("2019-07-18T15:25:00"),
+    ymd_hms("2019-07-18T15:00:00"),
     as.POSIXct("2019-07-18"),
     as.POSIXct("2019-02-01"),
     as.POSIXct(NA_character_),
     as.POSIXct(NA_character_),
-    as.POSIXct("2003-12-15T23:15:18"),
-    as.POSIXct("2003-12-15T13:59:19"),
-    as.POSIXct("2020-07-31T00:00:59"),
-    as.POSIXct("2020-07-31T00:00:59")
+    ymd_hms("2003-12-15T23:15:18"),
+    ymd_hms("2003-12-15T13:59:19"),
+    ymd_hms("2020-07-31T00:00:59"),
+    ymd_hms("2020-07-31T00:00:00"),
+    ymd_hms("2022-05-15T23:59:59"),
+    ymd_hms("2022-05-15T23:59:59"),
+    ymd_hms("2022-05-15T23:59:59")
   )
   expected_output <- c(
     NA_character_,
@@ -613,7 +619,10 @@ test_that("compute_tmf Test 30: compute TMF", {
     "H",
     "M",
     "S",
-    NA_character_
+    NA_character_,
+    "H",
+    "M",
+    "S"
   )
 
   expect_equal(