Convert POSIXct to Date directly

As of R-3.5.1, converting from POSIXct to Date creates an intermediate
POSIXlt vector. This uses a non-trivial amount of memory. Directly
converting from POSIXct to Date uses less memory and is roughly twice
as fast.

This solution is a combination of asPOSIXlt and POSIXlt2D from RCore.
The functions are essentially concatenated, with the extraneous parts
removed.

The function name 'asDatePOSIXct' differs from the other rapi* names
because it's not a RCore function. The name isn't as.Date.POSIXct() to
avoid clashes with the current (or future) S3 method.

NAMESPACE

@@ -4,4 +4,5 @@ export("rapistrptime",
        "rapiAsPOSIXct",
        "rapiFormatPOSIXlt",
        "rapiPOSIXlt2D",
-       "rapiD2POSIXlt")
+       "rapiD2POSIXlt",
+       "asDatePOSIXct")

R/asDatePOSIXct.R

@@ -0,0 +1,27 @@
+##' Conversion from POSIXct to Date
+##'
+##' This function provides a direct conversion from POSIXct to Date. As of
+##' R-3.5.1, conversion from POSIXct to Date creates an intermediate POSIXlt
+##' object. This intermediate POSIXlt object uses a non-trivial amount of
+##' memory. The direct conversion is more memory efficient, and therefore
+##' approximately twice as fast as the current solution in base R.
+##'
+##' @title Conversion from POSIXct to Date
+##' @param x A POSIXct vector
+##' @param tz An optional timezone string
+##' @return A vector of \code{Date} objects
+##' @author Joshua Ulrich
+##' @examples
+##' p <- .POSIXct(1540181413, "America/Chicago")
+##' as.Date(p)                     # Using UTC timezone
+##' as.Date(p, "America/Chicago")  # Using local timezone
+##' asDatePOSIXct(p)               # Direct, using local timezone
+asDatePOSIXct <- function(x, tz="") {
+    stopifnot(inherits(x, "POSIXct"))
+    tzone <- attr(x, "tzone")
+    if (missing(tz) && !is.null(tzone)) {
+        tz <- tzone
+    }
+    res <- .Call("POSIXct2D", x, tz, PACKAGE="RApiDatetime")
+    res
+}

src/datetime.c

@@ -1314,3 +1314,78 @@ SEXP POSIXlt2D(SEXP sxparg)
     UNPROTECT(3);
     return ans;
 }
+
+/* Convert POSIXct to Date
+ *
+ * This is a combination of asPOSIXlt and POSIXlt2D that avoids some overhead
+ * when as.Date() is called on a POSIXct object with a non-UTC timezone. It
+ * avoids the intermediate (memory-inefficient) allocation to POSIXlt by
+ * re-using one tm struct instance for all POSIXct elements.
+ *
+ * Author: RCore for asPOSIXlt and POSIXlt2D.
+ *         Joshua Ulrich for the mashup.
+ */
+SEXP POSIXct2D(SEXP argsxp, SEXP tzarg)
+{
+    SEXP stz, x = argsxp, klass;
+    int isgmt = 0, valid = 0, settz = 0;
+    char oldtz[1001] = "";
+    const char *tz = NULL;
+
+    if (!isString((stz = tzarg)) || LENGTH(stz) != 1)
+        error("invalid '%s' value", "tz");
+    tz = CHAR(STRING_ELT(stz, 0));
+    if(strlen(tz) == 0) {
+	/* do a direct look up here as this does not otherwise
+	   work on Windows */
+	char *p = getenv("TZ");
+	if(p) {
+	    stz = mkString(p); /* make a copy */
+	    tz = CHAR(STRING_ELT(stz, 0));
+	}
+    }
+    PROTECT(stz); /* it might be new */
+    if(strcmp(tz, "GMT") == 0  || strcmp(tz, "UTC") == 0) isgmt = 1;
+    if(!isgmt && strlen(tz) > 0) settz = set_tz(tz, oldtz);
+#ifdef USE_INTERNAL_MKTIME
+    else R_tzsetwall(); // to get the system timezone recorded
+#else
+    tzset();
+#endif
+
+    R_xlen_t n = XLENGTH(x);
+
+    SEXP date_ans = PROTECT(allocVector(INTSXP, n));
+    int* date_ans_ = INTEGER(date_ans);
+    double* x_ = REAL(x);
+
+    for(R_xlen_t i = 0; i < n; i++) {
+	stm dummy, *ptm = &dummy;
+	double d = x_[i];
+	if(R_FINITE(d)) {
+	    ptm = localtime0(&d, 1 - isgmt, &dummy);
+	    /* in theory localtime/gmtime always return a valid
+	       struct tm pointer, but Windows uses NULL for error
+	       conditions (like negative times). */
+	    valid = (ptm != NULL);
+	} else {
+            valid = 0;
+        }
+
+        if(valid) {
+	    ptm->tm_sec = ptm->tm_min = ptm->tm_hour = 0;
+	    ptm->tm_isdst = 0;
+	    /* -1 must be error as seconds were zeroed */
+	    double tmp = mktime00(ptm);
+	    date_ans_[i] = (tmp == -1) ? NA_INTEGER : tmp/86400;
+        } else {
+	    date_ans_[i] = NA_INTEGER;
+	}
+    }
+
+    if(settz) reset_tz(oldtz);
+    PROTECT(klass = mkString("Date"));
+    classgets(date_ans, klass);
+    UNPROTECT(3);
+    return date_ans;
+}

src/init.c

@@ -11,6 +11,7 @@ SEXP formatPOSIXlt(SEXP objarg, SEXP fmtarg, SEXP tzarg);
 SEXP Rstrptime(SEXP objarg, SEXP fmtarg, SEXP tzarg);
 SEXP POSIXlt2D(SEXP sxparg);
 SEXP D2POSIXlt(SEXP argsxp);
+SEXP POSIXct2D(SEXP, SEXP);
 
 
 /* definition of functions provided for .Call() 			*/
@@ -20,6 +21,7 @@ static const R_CallMethodDef callMethods[] = {
     { "formatPOSIXlt",       	(DL_FUNC) &formatPOSIXlt,           3 },
     { "Rstrptime",       	(DL_FUNC) &Rstrptime,               3 },
     { "POSIXlt2D",       	(DL_FUNC) &POSIXlt2D,               1 },
+    { "POSIXct2D",       	(DL_FUNC) &POSIXct2D,               2 },
     { "D2POSIXlt",       	(DL_FUNC) &D2POSIXlt,               1 },
     { NULL,                	NULL,                               0 }
 };
@@ -35,6 +37,7 @@ void R_init_RApiDatetime(DllInfo *info) {
     R_RegisterCCallable("RApiDatetime", "formatPOSIXlt", (DL_FUNC) &formatPOSIXlt);
     R_RegisterCCallable("RApiDatetime", "Rstrptime",     (DL_FUNC) &Rstrptime);
     R_RegisterCCallable("RApiDatetime", "POSIXlt2D",     (DL_FUNC) &POSIXlt2D);
+    R_RegisterCCallable("RApiDatetime", "POSIXct2D",     (DL_FUNC) &POSIXct2D);
     R_RegisterCCallable("RApiDatetime", "D2POSIXlt",     (DL_FUNC) &D2POSIXlt);
 
     R_registerRoutines(info,

tests/test.R

@@ -20,3 +20,4 @@ str(rapiD2POSIXlt(rapiPOSIXlt2D(X)))
 str(rapiFormatPOSIXlt(X, "%Y-%b-%d %H:%M:%OS"))
 str(rapiFormatPOSIXlt(X, "%Y-%b-%d %H:%M:%OS", TRUE))
 
+str(asDatePOSIXct(.POSIXct(1540181413, "America/Chicago")))