[Fix #412] Add make_date

NAMESPACE

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

NEWS.md

@@ -1,6 +1,11 @@
 Version 1.5.6.9000 (development)
 ============
 
+### NEW FEATURES
+
+* [#412](https://github.com/hadley/lubridate/issues/412) New function `make_date` to produce Date objects. A counterpart of `make_datetime`.
+
+
 ### CHANGES
 
 * [#403](https://github.com/hadley/lubridate/issues/403) Update on `Date` objects now return `POSIXct` instead of `POSIXlt`.

R/instants.r

@@ -82,14 +82,15 @@ today <- function(tzone = "") {
 origin <- with_tz(structure(0, class = c("POSIXct", "POSIXt")), "UTC")
 
 
-##' Efficient creation of date-times from numeric representations.
+##' Efficient creation of date-times from numeric representations
 ##'
 ##' \code{make_datetime} is a very fast drop-in replacement for
-##' \code{base::ISOdate} and \code{base::ISOdatetime}.
+##' \code{base::ISOdate} and \code{base::ISOdatetime}. \code{make_date} produces
+##' objects of class \code{Date}.
 ##'
 ##' Input vectors are silently recycled. All inputs except \code{sec} are
-##' silently converted to integer vectors. Seconds \code{sec} can be either
-##' integer or double.
+##' silently converted to integer vectors; \code{sec} can be either integer or
+##' double.
 ##'
 ##' @param year numeric year
 ##' @param month numeric month
@@ -105,7 +106,7 @@ origin <- with_tz(structure(0, class = c("POSIXct", "POSIXt")), "UTC")
 ##' ## "1999-12-22 00:00:10 UTC"
 ##' make_datetime(year = 1999, month = 12, day = 22, sec = c(10, 11))
 ##' ## "1999-12-22 00:00:10 UTC" "1999-12-22 00:00:11 UTC"
-make_datetime <- function(year = 1970, month = 1L, day = 1L, hour = 0, min = 0, sec = 0, tz = "UTC"){
+make_datetime <- function(year = 1970L, month = 1L, day = 1L, hour = 0L, min = 0L, sec = 0, tz = "UTC"){
   lengths <- vapply(list(year, month, day, hour, min, sec), length, 1, USE.NAMES = FALSE)
   if (min(lengths) == 0L){
     .POSIXct(numeric(), tz = tz)
@@ -121,3 +122,22 @@ make_datetime <- function(year = 1970, month = 1L, day = 1L, hour = 0, min = 0,
              tz = tz)
   }
 }
+
+##' @rdname make_datetime
+##' @export
+make_date <- function(year = 1970L, month = 1L, day = 1L){
+  lengths <- vapply(list(year, month, day), length, 1, USE.NAMES = FALSE)
+  if (min(lengths) == 0L){
+    character()
+  } else {
+    N <- max(lengths)
+    secs <- .Call("make_dt",
+                  rep_len(as.integer(year), N),
+                  rep_len(as.integer(month), N),
+                  rep_len(as.integer(day), N),
+                  rep_len(0L, N),
+                  rep_len(0L, N),
+                  rep_len(0L, N))
+    structure(floor(secs/86400), class = "Date")
+  }
+}

tests/testthat/test-instants.R

@@ -4,18 +4,18 @@ test_that("is.instant/is.timepoint works as expected",{
   expect_that(is.instant(234), is_false())
   expect_that(is.instant(as.POSIXct("2008-08-03 13:01:59", tz = "UTC")),
     is_true())
-  expect_that(is.instant(as.POSIXlt("2008-08-03 13:01:59", tz = "UTC")), 
+  expect_that(is.instant(as.POSIXlt("2008-08-03 13:01:59", tz = "UTC")),
     is_true())
   expect_that(is.instant(Sys.Date()), is_true())
   expect_that(is.instant(minutes(1)), is_false())
   expect_that(is.timespan(interval(
-    as.POSIXct("2008-08-03 13:01:59", tz = "UTC"), 
+    as.POSIXct("2008-08-03 13:01:59", tz = "UTC"),
     as.POSIXct("2009-08-03 13:01:59", tz = "UTC") )), is_true())
 })
 
 test_that("is.instant/is.timepoint handle vectors",{
   expect_that(is.instant(minutes(1:2)), is_false())
-  expect_that(is.instant(as.POSIXct(c("2008-08-03 13:01:59", 
+  expect_that(is.instant(as.POSIXct(c("2008-08-03 13:01:59",
   	"2008-08-03 13:01:59"), tz = "UTC")), is_true())
 })
 
@@ -32,7 +32,7 @@ test_that("today() works correctly",{
 test_that("make_datetime returns same values as ISOdatetime", {
 
   set.seed(1000)
-  
+
   N <- 1e4
   y <- as.integer(runif(N, 1800, 2200))
   m <- as.integer(runif(N, 1, 12))
@@ -50,6 +50,9 @@ test_that("make_datetime returns same values as ISOdatetime", {
   out1 <- ISOdatetime(y, m, d, H, M, S, tz = "UTC")
   out2 <- make_datetime(y, m, d, H, M, S)
   expect_equal(out1, out2)
+
+  out3 <- make_date(y, m, d)
+  expect_equal(as.Date(out1), out3)
 })
 
 test_that("make_datetime replicates as expected", {
@@ -58,6 +61,6 @@ test_that("make_datetime replicates as expected", {
 })
 
 test_that("make_datetime propagates NAs as expected", {
-  expect_equal(make_datetime(year = 1999, month = c(11, NA), day = 22, sec = c(10, 11, NA)), 
+  expect_equal(make_datetime(year = 1999, month = c(11, NA), day = 22, sec = c(10, 11, NA)),
                as.POSIXct(c("1999-11-22 00:00:10 UTC", NA, NA), tz = "UTC"))
 })