Implement leap_year() in C

R/leap-years.r

@@ -21,5 +21,5 @@ leap_year <- function(date) {
   } else {
     year <- year(date)
   }
-  (year %% 4 == 0) & ((year %% 100 != 0) | (year %% 400 == 0))
+  .Call(C_is_leap_year, as.integer(year))
 }

src/init.c

@@ -8,12 +8,14 @@ extern SEXP C_make_d(SEXP, SEXP, SEXP);
 extern SEXP C_parse_dt(SEXP, SEXP, SEXP, SEXP, SEXP);
 extern SEXP C_parse_hms(SEXP, SEXP);
 extern SEXP C_parse_period(SEXP);
+extern SEXP C_is_leap_year(SEXP);
 
 static const R_CallMethodDef CallEntries[] = {
   {"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},
   {"C_parse_period",        (DL_FUNC) &C_parse_period,        1},
+  {"C_is_leap_year",        (DL_FUNC) &C_is_leap_year,        1},
   {NULL, NULL, 0}
 };
 

src/utils.c

@@ -27,6 +27,27 @@
 #include <ctype.h>
 #include <Rinternals.h>
 
+SEXP C_is_leap_year(SEXP year) {
+  if(!isInteger(year)) error("year must be integer");
+
+  R_len_t n = LENGTH(year);
+  int* pyear = INTEGER(year);
+
+  SEXP res = allocVector(LGLSXP, n);
+  int *data = LOGICAL(res);
+
+  for(int i = 0; i < n; i++) {
+    int y = pyear[i];
+    if(y == NA_INTEGER) {
+      data[i] = NA_LOGICAL;
+    } else {
+      data[i] = IS_LEAP(y);
+    }
+  }
+
+  return res;
+}
+
 // return adjustment (in seconds) due to leap years
 // y: years after (positive) or before (negative) 2000-01-01 00:00:00
 int adjust_leap_years(int y, int m, int is_leap){

tests/testthat/test-utilities.R

@@ -6,6 +6,10 @@ test_that("leap_year correctly identifies leap years", {
   expect_true(leap_year(y))
 })
 
+test_that("leap_year handles missing values", {
+  expect_equal(leap_year(NA), NA)
+})
+
 test_that("leap_year handles various date-time vectors", {
   x <- as.POSIXct(c("2008-08-03 12:01:59", "2009-08-03 12:01:59"), tz = "UTC")