[#438] New function local_time for the retrieval of local day time

NAMESPACE

@@ -159,6 +159,7 @@ export(is.timespan)
 export(isoweek)
 export(isoyear)
 export(leap_year)
+export(local_time)
 export(make_date)
 export(make_datetime)
 export(make_difftime)

NEWS.md

@@ -4,6 +4,7 @@ Version 1.6.0.9000
 ### NEW FEATURES
 
 * [#438](https://github.com/tidyverse/lubridate/issues/438) New function `force_tzs` for "enforcement" of heterogeneous time zones.
+* [#438](https://github.com/tidyverse/lubridate/issues/438) New function `local_time` for the retrieval of local day time in different time zones.
 * [#560](https://github.com/tidyverse/lubridate/issues/560) New argument `cutoff_2000` for parsing functions to indicate 20th century cutoff for `y` format.
 * [#257](https://github.com/tidyverse/lubridate/issues/257) New `week_start` parameter in `wday` and `wday<-` to set week start.
 * [#401](https://github.com/tidyverse/lubridate/issues/401) New parameter `locale` in `wday`. Labels of the returned factors (when `label=TRUE`) now respect current locale.

R/RcppExports.R

@@ -13,3 +13,7 @@ C_force_tzs <- function(dt, tzs, tz_out, roll = FALSE) {
     .Call(`_lubridate_C_force_tzs`, dt, tzs, tz_out, roll)
 }
 
+C_local_time <- function(dt, tzs) {
+    .Call(`_lubridate_C_local_time`, dt, tzs)
+}
+

R/stamp.r

@@ -34,7 +34,7 @@
 ##' `locale -a` in the terminal to list available locales.
 ##' @param quiet whether to output informative messages.
 ##' @return a function to be applied on a vector of dates
-##' @seealso \link{guess_formats}, \link{parse_date_time}, \link{strptime}
+##' @seealso [guess_formats()], [parse_date_time()], [strptime()]
 ##' @export
 ##' @examples
 ##' D <- ymd("2010-04-05") - days(1:5)

R/time-zones.r

@@ -59,7 +59,7 @@ with_tz <- function (time, tzone = "") {
 #'   the next valid civil time, otherwise return NA. See examples.
 #' @return a POSIXct object in the updated time zone
 #' @keywords chron manip
-#' @seealso [with_tz()]
+#' @seealso [with_tz()], [local_time()]
 #' @examples
 #' x <- ymd_hms("2009-08-07 00:00:01", tz = "America/New_York")
 #' force_tz(x, "UTC")
@@ -104,3 +104,39 @@ force_tzs <- function(time, tzones, tzone_out = "UTC", roll = FALSE) {
   out <- C_force_tzs(as.POSIXct(time), tzones, tzone_out, roll)
   reclass_date(out, time)
 }
+
+#' Get local time from a date-time vector.
+#'
+#' `local_time` retrieves day clock time in specified time zones. Computation is
+#' vectorized over both `dt` and `tz` arguments, the shortest is recycled in
+#' accordance with standard R rules.
+#'
+#' @param dt a date-time object.
+#' @param tz a character vector of timezones for which to compute the local time.
+#' @param units passed directly to [as.difftime()].
+#' @examples
+#'
+#' x <- ymd_hms(c("2009-08-07 01:02:03", "2009-08-07 10:20:30"))
+#' local_time(x, units = "secs")
+#' local_time(x, units = "hours")
+#' local_time(x, "Europe/Amsterdam")
+#' local_time(x, "Europe/Amsterdam") == local_time(with_tz(x, "Europe/Amsterdam"))
+#'
+#' x <- ymd_hms("2009-08-07 01:02:03")
+#' local_time(x, c("America/New_York", "Europe/Amsterdam", "Asia/Shanghai"), unit = "hours")
+#' @export
+local_time <- function(dt, tz = NULL, units = "secs") {
+  if (is.null(tz))
+    tz <- tz(dt)
+  if (length(tz) < length(dt))
+    tz <- rep_len(tz, length(dt))
+  else if (length(tz) > length(dt)) {
+    attr <- attributes(dt)
+    dt <- rep_len(dt, length(tz))
+    attributes(dt) <- attr
+  }
+  secs <- C_local_time(as.POSIXct(dt), tz)
+  out <- structure(secs, units = "secs", class = "difftime")
+  units(out) <- units
+  out
+}

src/RcppExports.cpp

@@ -54,6 +54,18 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
+// C_local_time
+Rcpp::NumericVector C_local_time(const Rcpp::NumericVector dt, const Rcpp::CharacterVector tzs);
+RcppExport SEXP _lubridate_C_local_time(SEXP dtSEXP, SEXP tzsSEXP) {
+BEGIN_RCPP
+    Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< const Rcpp::NumericVector >::type dt(dtSEXP);
+    Rcpp::traits::input_parameter< const Rcpp::CharacterVector >::type tzs(tzsSEXP);
+    rcpp_result_gen = Rcpp::wrap(C_local_time(dt, tzs));
+    return rcpp_result_gen;
+END_RCPP
+}
 
 RcppExport SEXP C_make_d(SEXP, SEXP, SEXP);
 RcppExport SEXP C_parse_dt(SEXP, SEXP, SEXP, SEXP, SEXP);
@@ -64,6 +76,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"_lubridate_C_update_dt", (DL_FUNC) &_lubridate_C_update_dt, 12},
     {"_lubridate_C_force_tz", (DL_FUNC) &_lubridate_C_force_tz, 3},
     {"_lubridate_C_force_tzs", (DL_FUNC) &_lubridate_C_force_tzs, 4},
+    {"_lubridate_C_local_time", (DL_FUNC) &_lubridate_C_local_time, 2},
     {"C_make_d",               (DL_FUNC) &C_make_d,                3},
     {"C_parse_dt",             (DL_FUNC) &C_parse_dt,              5},
     {"C_parse_hms",            (DL_FUNC) &C_parse_hms,             2},

src/update.cpp

@@ -272,7 +272,7 @@ Rcpp::newDatetimeVector C_force_tzs(const Rcpp::NumericVector dt,
   load_tz_or_fail(tzfrom_name, tzfrom, "Invalid timezone of input vector: \"%s\"");
   load_tz_or_fail(tzout_name, tzout, "Unrecognized timezone: \"%s\"");
 
-  std::string tzto_old_name("");
+  std::string tzto_old_name("not-a-tz");
   size_t n = dt.size();
   Rcpp::NumericVector out(n);
 
@@ -297,3 +297,38 @@ Rcpp::newDatetimeVector C_force_tzs(const Rcpp::NumericVector dt,
 
   return Rcpp::newDatetimeVector(out, tzout_name.c_str());
 }
+
+// [[Rcpp::export]]
+Rcpp::NumericVector C_local_time(const Rcpp::NumericVector dt,
+                                 const Rcpp::CharacterVector tzs) {
+
+  if (tzs.size() != dt.size())
+    Rcpp::stop("`tzs` and `dt` arguments must be of the same length");
+
+  std::string tzfrom_name = get_tzone_attr(dt);
+  std::string tzto_old_name("not-a-tz");
+  cctz::time_zone tzto;
+
+  size_t n = dt.size();
+  Rcpp::NumericVector out(n);
+
+  for (size_t i = 0; i < n; i++)
+    {
+      std::string tzto_name(tzs[i]);
+      if (tzto_name != tzto_old_name) {
+        load_tz_or_fail(tzto_name, tzto, "Unrecognized timezone: \"%s\"");
+        tzto_old_name = tzto_name;
+      }
+
+      int_fast64_t secs = std::floor(dt[i]);
+      double rem = dt[i] - secs;
+
+      sys_seconds secsfrom(secs);
+      time_point tpfrom(secsfrom);
+      cctz::civil_second cs = cctz::convert(tpfrom, tzto);
+      cctz::civil_second cs_floor = cctz::civil_second(cctz::civil_day(cs));
+      out[i] = cs - cs_floor + rem;
+    }
+
+  return out;
+}

tests/testthat/test-timezones.R

@@ -37,17 +37,30 @@ test_that("with_tz handles data.frames", {
 })
 
 test_that("force_tzs works as expected", {
-
+  x <- ymd_hms(c("2009-08-07 00:00:01", "2009-08-07 00:00:01"))
   expect_equal(force_tzs(x, tzones = c("America/New_York", "Europe/Amsterdam")),
                ymd_hms("2009-08-07 04:00:01 UTC", "2009-08-06 22:00:01 UTC"))
-
   expect_equal(force_tzs(x, tzones = c("America/New_York", "Europe/Amsterdam"), tzone_out = "America/New_York"),
                ymd_hms("2009-08-07 00:00:01 EDT", "2009-08-06 18:00:01 EDT", tz = "America/New_York"))
-
   ## recycling
   expect_equal(force_tzs(x, tzones = "America/New_York", tzone_out = "UTC"),
                ymd_hms("2009-08-07 04:00:01 UTC", "2009-08-07 04:00:01 UTC"))
+})
 
+test_that("local_time works as expected", {
+  x <- ymd_hms(c("2009-08-07 01:02:03", "2009-08-07 10:20:30"))
+  expect_equal(local_time(x, units = "secs"),
+               as.difftime(c(3723, 37230), units = "secs"))
+  expect_equal(local_time(x, units = "hours"),
+               as.difftime(c(3723, 37230)/3600, units = "hours"))
+  expect_equal(local_time(x, "Europe/Amsterdam"),
+               local_time(with_tz(x, "Europe/Amsterdam")))
+
+  x <- ymd_hms("2009-08-07 01:02:03")
+  expect_equal(local_time(x, c("America/New_York", "Europe/Amsterdam", "Asia/Shanghai")),
+               c(local_time(with_tz(x, "America/New_York")),
+                 local_time(with_tz(x, "Europe/Amsterdam")),
+                 local_time(with_tz(x, "Asia/Shanghai"))))
 })
 
 test_that("force_tz works as expected", {