Merge b31640d into bd855b4

DESCRIPTION

@@ -36,6 +36,7 @@ Imports:
     glue (>= 1.0.0),
     grid,
     lifecycle (>= 0.2.0),
+    lubridate,
     magrittr (>= 1.5),
     methods,
     nestcolor (>= 0.1.1),

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(assert_valid_var,POSIXct)
 S3method(assert_valid_var,character)
 S3method(assert_valid_var,default)
 S3method(assert_valid_var,factor)
@@ -254,6 +255,7 @@ importFrom(glue,glue)
 importFrom(grid,stringWidth)
 importFrom(grid,unit)
 importFrom(lifecycle,deprecated)
+importFrom(lubridate,force_tz)
 importFrom(magrittr,"%>%")
 importFrom(methods,is)
 importFrom(methods,setValidity)

R/assertions.R

@@ -80,6 +80,7 @@ assert_valid_var.logical <- function(x, label = deparse(substitute(x)), na_ok =
     ...
   )
 }
+
 #' @rdname assert_valid_var
 #' @param integerish (`flag`) whether the number should be treated as `integerish`.
 #' @export
@@ -96,6 +97,35 @@ assert_valid_var.numeric <- function(
   )
 }
 
+#' @rdname assert_valid_var
+#' @param tzs (`character`) time zones.
+#' @export
+assert_valid_var.POSIXct <- function(x,
+                                     label = deparse(substitute(x)),
+                                     na_ok = TRUE,
+                                     empty_ok = FALSE,
+                                     tzs = OlsonNames(),
+                                     ...) {
+  assert_posixct(
+    x,
+    min.len = as.integer(!empty_ok),
+    any.missing = na_ok,
+    .var.name = label,
+    ...
+  )
+
+  extra_args <- list(...)
+
+  # Test if time zone of x is in OlsonNames
+  if (lubridate::tz(x) %in% tzs) {
+    return(invisible(NULL))
+  } else if (is(extra_args$add, "AssertCollection")) {
+    extra_args$add$push(paste("Non standard timezone detected for", label, "!"))
+  } else {
+    abort(paste("Non standard timezone detected for", label, "!"))
+  }
+}
+
 #' @rdname assert_valid_var
 #' @export
 assert_valid_var.default <- function(x, label = deparse(substitute(x)), na_ok = FALSE, empty_ok = FALSE, ...) {

R/package.R

@@ -12,6 +12,7 @@
 #' @importFrom grid stringWidth unit
 #' @importFrom glue glue
 #' @importFrom lifecycle deprecated
+#' @importFrom lubridate force_tz
 #' @importFrom magrittr %>%
 #' @importFrom methods is setValidity
 #' @importFrom nestcolor color_palette

R/utils.R

@@ -438,11 +438,23 @@ listing_format_chevron <- function() {
 #'
 #' @return a `function` converting a date into `string`.
 #'
-#' @export
+#' @note The date is extracted at the location of the measure, not at the location of the system.
 #'
+#' @export
+#' @examples
+#' format_date("%d%b%Y")(as.Date("2021-01-01"))
+#' format_date("%d%b%Y")(as.POSIXct("2021-01-01 00:00:01", tz = "NZ"))
+#' format_date("%d%b%Y")(as.POSIXct("2021-01-01 00:00:01", tz = "US/Pacific"))
 format_date <- function(date_format = "%d%b%Y") {
   function(x, ...) {
-    toupper(strftime(as.Date(x, tz = ""), format = date_format))
+    toupper(
+      format(
+        # Extract the date at the location of the measure, not at the location of the system.
+        lubridate::force_tz(x, tzone = "UTC"),
+        date_format,
+        tz = "UTC"
+      )
+    )
   }
 }
 

data-raw/syn_data_creation.R

@@ -195,6 +195,7 @@ syn_test_data <- function() {
     mutate(AREL = .data$AEREL) %>%
     mutate(ATOXGR = .data$AETOXGR)
 
+  sd$adae$TRTSDTM <- lubridate::force_tz(sd$adae$TRTSDTM, tzone = "UTC")
   sd$adae$ADURN <- sd$adae$AENDY - sd$adae$ASTDY + 1
   # dsl01
   sd$adsl$TRTDURD <- as.numeric(ceiling(difftime(sd$adsl$TRTEDTM, sd$adsl$TRTSDTM, units = "days")))

tests/testthat/test-assertions.R

@@ -61,6 +61,14 @@ test_that("assert_valid_var.numeric works as expected", {
   expect_silent(assert_valid_var(x, integerish = TRUE))
 })
 
+test_that("assert_valid_var.POSIXct works as expected", {
+  x <- as.POSIXct("2020-01-01", "UTC")
+  expect_silent(assert_valid_var(x, na_ok = TRUE))
+
+  x <- as.POSIXct("2020-01-01", "")
+  expect_error(assert_valid_var(x), "Non standard timezone detected for x !")
+})
+
 
 # assert_valid_variable ----
 

tests/testthat/test-utils.R

@@ -315,3 +315,31 @@ test_that("gg_list is deprecated", {
     }
   )
 })
+
+test_that("format_date works as expected for POSIXct", {
+  d <- as.POSIXct("2019-01-01 00:00:01", tz = "NZ")
+
+  withr::with_timezone("Europe/Paris", {
+    foo <- format_date()
+    expect_identical(foo(d), "01JAN2019")
+  })
+
+  withr::with_timezone("NZ", {
+    foo <- format_date()
+    expect_identical(foo(d), "01JAN2019")
+  })
+})
+
+test_that("format_date works as expected for Date", {
+  d <- as.Date("2019-01-01 00:00:01", tz = "NZ")
+
+  withr::with_timezone("Europe/Paris", {
+    foo <- format_date()
+    expect_identical(foo(d), "01JAN2019")
+  })
+
+  withr::with_timezone("NZ", {
+    foo <- format_date()
+    expect_identical(foo(d), "01JAN2019")
+  })
+})