tidyverse / lubridate
Showing 5 of 15 files from the diff.

@@ -90,11 +90,11 @@
Loading
90 90
    time
91 91
  } else {
92 92
    if (is.POSIXct(time))
93 -
      C_force_tz(time, tz = tzone, roll)
93 +
      cpp_force_tz(time, tz = tzone, roll)
94 94
    else if (is.Date(time))
95 -
      C_force_tz(date_to_posix(time), tz = tzone, roll)
95 +
      cpp_force_tz(date_to_posix(time), tz = tzone, roll)
96 96
    else {
97 -
      out <- C_force_tz(as.POSIXct(time, tz = tz(time)), tz = tzone, roll)
97 +
      out <- cpp_force_tz(as.POSIXct(time, tz = tz(time)), tz = tzone, roll)
98 98
      reclass_date(out, time)
99 99
    }
100 100
  }
@@ -124,7 +124,7 @@
Loading
124 124
    time <- rep_len(time, length(tzones))
125 125
    attributes(time) <- attr
126 126
  }
127 -
  out <- C_force_tzs(as.POSIXct(time), tzones, tzone_out, roll)
127 +
  out <- cpp_force_tzs(as.POSIXct(time), tzones, tzone_out, roll)
128 128
  reclass_date(out, time)
129 129
}
130 130
@@ -158,7 +158,7 @@
Loading
158 158
    dt <- rep_len(dt, length(tz))
159 159
    attributes(dt) <- attr
160 160
  }
161 -
  secs <- C_local_time(as.POSIXct(dt), tz)
161 +
  secs <- cpp_local_time(as.POSIXct(dt), tz)
162 162
  out <- structure(secs, units = "secs", class = "difftime")
163 163
  units(out) <- units
164 164
  out

@@ -101,10 +101,20 @@
Loading
101 101
    .POSIXct(numeric(), tz = tz)
102 102
  } else {
103 103
    N <- max(lengths)
104 -
    C_update_dt(.rep_maybe(origin, N), year = .rep_maybe(year, N), month = .rep_maybe(month, N),
105 -
                yday = integer(), mday = .rep_maybe(day, N), wday = integer(),
106 -
                hour = .rep_maybe(hour, N), minute = .rep_maybe(min, N),
107 -
                second = .rep_maybe(sec, N), tz = tz)
104 +
    cpp_update_dt(
105 +
      dt = .rep_maybe(origin, N),
106 +
      year = .rep_maybe(year, N),
107 +
      month = .rep_maybe(month, N),
108 +
      yday = integer(),
109 +
      mday = .rep_maybe(day, N),
110 +
      wday = integer(),
111 +
      hour = .rep_maybe(hour, N),
112 +
      minute = .rep_maybe(min, N),
113 +
      second = .rep_maybe(sec, N),
114 +
      tz = tz,
115 +
      roll = FALSE,
116 +
      week_start = 7L
117 +
    )
108 118
  }
109 119
}
110 120

@@ -68,7 +68,7 @@
Loading
68 68
  updates[["roll"]] <- roll
69 69
  updates[["tz"]] <- tzs
70 70
  updates[["week_start"]] <- week_start
71 -
  reclass_date(do.call(C_update_dt, updates), object)
71 +
  reclass_date(do.call(cpp_update_dt, updates), object)
72 72
}
73 73
74 74
## prior to v1.7.0

@@ -0,0 +1,90 @@
Loading
1 +
cpp_update_dt <- function(dt,
2 +
                          year,
3 +
                          month,
4 +
                          yday,
5 +
                          mday,
6 +
                          wday,
7 +
                          hour,
8 +
                          minute,
9 +
                          second,
10 +
                          tz,
11 +
                          roll,
12 +
                          week_start) {
13 +
  # Catch rare integer POSIXct, retaining attributes
14 +
  storage.mode(dt) <- "double"
15 +
16 +
  year <- as.integer(year)
17 +
  month <- as.integer(month)
18 +
  yday <- as.integer(yday)
19 +
  mday <- as.integer(mday)
20 +
  wday <- as.integer(wday)
21 +
  hour <- as.integer(hour)
22 +
  minute <- as.integer(minute)
23 +
24 +
  second <- as.double(second)
25 +
26 +
  roll <- as.logical(roll)
27 +
  week_start <- as.integer(week_start)
28 +
29 +
  C_update_dt(
30 +
    dt = dt,
31 +
    year = year,
32 +
    month = month,
33 +
    yday = yday,
34 +
    mday = mday,
35 +
    wday = wday,
36 +
    hour = hour,
37 +
    minute = minute,
38 +
    second = second,
39 +
    tz = tz,
40 +
    roll = roll,
41 +
    week_start = week_start
42 +
  )
43 +
}
44 +
45 +
cpp_force_tz <- function(dt, tz, roll) {
46 +
  # Catch rare integer POSIXct, retaining attributes
47 +
  storage.mode(dt) <- "double"
48 +
49 +
  roll <- as.logical(roll)
50 +
51 +
  # Must be a character vector, never `NULL`
52 +
  tz <- as.character(tz)
53 +
54 +
  C_force_tz(
55 +
    dt = dt,
56 +
    tz = tz,
57 +
    roll = roll
58 +
  )
59 +
}
60 +
61 +
cpp_force_tzs <- function(dt, tzs, tz_out, roll) {
62 +
  # Catch rare integer POSIXct, retaining attributes
63 +
  storage.mode(dt) <- "double"
64 +
65 +
  # Must be a character vector, never `NULL`
66 +
  tzs <- as.character(tzs)
67 +
  tz_out <- as.character(tz_out)
68 +
69 +
  roll <- as.logical(roll)
70 +
71 +
  C_force_tzs(
72 +
    dt = dt,
73 +
    tzs = tzs,
74 +
    tz_out = tz_out,
75 +
    roll = roll
76 +
  )
77 +
}
78 +
79 +
cpp_local_time <- function(dt, tzs) {
80 +
  # Catch rare integer POSIXct, retaining attributes
81 +
  storage.mode(dt) <- "double"
82 +
83 +
  # Must be a character vector, never `NULL`
84 +
  tzs <- as.character(tzs)
85 +
86 +
  C_local_time(
87 +
    dt = dt,
88 +
    tzs = tzs
89 +
  )
90 +
}

@@ -1,10 +1,11 @@
Loading
1 1
#include <cstdint>
2 2
#include <limits>
3 3
#include <unordered_map>
4 +
#include <vector>
4 5
#include "cctz/civil_time.h"
5 6
#include "cctz/time_zone.h"
7 +
#include <cpp11.hpp>
6 8
#include "utils.h"
7 -
#include <Rcpp.h>
8 9
9 10
// CIVIL TIME:
10 11
// https://github.com/google/cctz/blob/master/include/civil_time.h
@@ -56,7 +57,7 @@
Loading
56 57
    return "";
57 58
  } else {
58 59
    if (!Rf_isString(tz))
59 -
      Rf_error("'tz' is not a character vector");
60 +
      cpp11::stop("'tz' is not a character vector");
60 61
    const char* tz0 = CHAR(STRING_ELT(tz, 0));
61 62
    if (strlen(tz0) == 0) {
62 63
      if (LENGTH(tz) > 1) {
@@ -73,19 +74,18 @@
Loading
73 74
74 75
const char* get_current_tz() {
75 76
  // ugly workaround to get local time zone (abbreviation) as seen by R (not used)
76 -
  Rcpp::NumericVector origin = Rcpp::NumericVector::create(0);
77 -
  origin.attr("class") = Rcpp::CharacterVector::create("POSIXct", "POSIXt");
78 -
  Rcpp::Environment base = Rcpp::Environment::base_namespace();
79 -
  Rcpp::Function as_posixlt(base["as.POSIXlt.POSIXct"]);
80 -
  return tz_from_R_tzone(as_posixlt(origin));
77 +
  cpp11::writable::doubles origin(1);
78 +
  origin[0] = 0;
79 +
  origin.attr("class") = {"POSIXct", "POSIXt"};
80 +
  auto as_posixlt = cpp11::package("base")["as.POSIXlt.POSIXct"];
81 +
  return tz_from_tzone_attr(as_posixlt(origin));
81 82
}
82 83
83 84
const char* get_system_tz() {
84 -
  Rcpp::Environment base = Rcpp::Environment::base_namespace();
85 -
  Rcpp::Function sys_timezone(base["Sys.timezone"]);
85 +
  auto sys_timezone = cpp11::package("base")["Sys.timezone"];
86 86
  SEXP sys_tz = STRING_ELT(sys_timezone(), 0);
87 87
  if (sys_tz == NA_STRING || strlen(CHAR(sys_tz)) == 0) {
88 -
    Rf_warning("System timezone name is unknown. Please set environment variable TZ.");
88 +
    cpp11::warning("System timezone name is unknown. Please set environment variable TZ.");
89 89
    return "UTC";
90 90
  } else {
91 91
    return CHAR(sys_tz);
@@ -102,7 +102,7 @@
Loading
102 102
    // FIXME:
103 103
    // if set but empty, it's system specific ...
104 104
    // Is there a way way to get TZ name as R sees it?
105 -
    Rf_warning("Environment variable TZ is set to \"\". Things might break.");
105 +
    cpp11::warning("Environment variable TZ is set to \"\". Things might break.");
106 106
    return get_current_tz();
107 107
  }
108 108
  else {
@@ -129,21 +129,23 @@
Loading
129 129
  }
130 130
}
131 131
132 -
// [[Rcpp::export]]
133 -
Rcpp::CharacterVector C_local_tz() {
134 -
    return Rf_mkString(local_tz());
132 +
[[cpp11::register]]
133 +
cpp11::writable::strings C_local_tz() {
134 +
  const char* tz = local_tz();
135 +
  cpp11::writable::strings out({tz});
136 +
  return out;
135 137
}
136 138
137 -
// [[Rcpp::export]]
138 -
Rcpp::LogicalVector C_valid_tz(const Rcpp::CharacterVector& tz_name) {
139 +
[[cpp11::register]]
140 +
bool C_valid_tz(const cpp11::strings& tz_name) {
139 141
  cctz::time_zone tz;
140 -
  std::string tzstr(tz_name[0]);
142 +
  std::string tzstr = tz_name[0];
141 143
  return load_tz(tzstr, tz);
142 144
}
143 145
144 146
void load_tz_or_fail(std::string tzstr, cctz::time_zone& tz, std::string error_msg) {
145 147
  if (!load_tz(tzstr, tz)) {
146 -
    Rcpp::stop(error_msg.c_str(), tzstr);
148 +
    cpp11::stop(error_msg.c_str(), tzstr.c_str());
147 149
  }
148 150
}
149 151
@@ -176,30 +178,42 @@
Loading
176 178
    } else {
177 179
      tp_new = cl_new.pre;
178 180
    }
179 -
    /* Rcpp::Rcout << cctz::format("tp:%Y-%m-%d %H:%M:%S %z", tp1, tz1) << std::endl; */
180 -
    /* Rcpp::Rcout << cctz::format("pre:%Y-%m-%d %H:%M:%S %z", cl1.pre, tz1) << std::endl; */
181 -
    /* Rcpp::Rcout << cctz::format("trans:%Y-%m-%d %H:%M:%S %z", cl1.trans, tz1) << std::endl; */
182 -
    /* Rcpp::Rcout << cctz::format("post:%Y-%m-%d %H:%M:%S %z", cl1.post, tz1) << std::endl; */
181 +
    /* std::cout << cctz::format("tp:%Y-%m-%d %H:%M:%S %z", tp1, tz1) << std::endl; */
182 +
    /* std::cout << cctz::format("pre:%Y-%m-%d %H:%M:%S %z", cl1.pre, tz1) << std::endl; */
183 +
    /* std::cout << cctz::format("trans:%Y-%m-%d %H:%M:%S %z", cl1.trans, tz1) << std::endl; */
184 +
    /* std::cout << cctz::format("post:%Y-%m-%d %H:%M:%S %z", cl1.post, tz1) << std::endl; */
183 185
  }
184 186
185 187
  return tp_new.time_since_epoch().count() + remainder;
186 188
}
187 189
188 -
// [[Rcpp::export]]
189 -
Rcpp::newDatetimeVector C_update_dt(const Rcpp::NumericVector& dt,
190 -
                                    const Rcpp::IntegerVector& year,
191 -
                                    const Rcpp::IntegerVector& month,
192 -
                                    const Rcpp::IntegerVector& yday,
193 -
                                    const Rcpp::IntegerVector& mday,
194 -
                                    const Rcpp::IntegerVector& wday,
195 -
                                    const Rcpp::IntegerVector& hour,
196 -
                                    const Rcpp::IntegerVector& minute,
197 -
                                    const Rcpp::NumericVector& second,
198 -
                                    const SEXP tz = R_NilValue,
199 -
                                    const bool roll = false,
200 -
                                    const int week_start = 7) {
201 -
202 -
  if (dt.size() == 0) return(Rcpp::newDatetimeVector(dt));
190 +
static inline void init_posixct(cpp11::writable::doubles& x, const char* tz) {
191 +
  x.attr("class") = {"POSIXct", "POSIXt"};
192 +
  x.attr("tzone") = tz;
193 +
}
194 +
195 +
[[cpp11::register]]
196 +
cpp11::writable::doubles C_update_dt(const cpp11::doubles& dt,
197 +
                                     const cpp11::integers& year,
198 +
                                     const cpp11::integers& month,
199 +
                                     const cpp11::integers& yday,
200 +
                                     const cpp11::integers& mday,
201 +
                                     const cpp11::integers& wday,
202 +
                                     const cpp11::integers& hour,
203 +
                                     const cpp11::integers& minute,
204 +
                                     const cpp11::doubles& second,
205 +
                                     const SEXP tz,
206 +
                                     const bool roll,
207 +
                                     const int week_start) {
208 +
209 +
  if (dt.size() == 0) {
210 +
    // TODO: Why does time zone comes from `dt` and not `tz`?
211 +
    const char* dt_tz = tz_from_tzone_attr(dt);
212 +
    const R_xlen_t out_size = 0;
213 +
    cpp11::writable::doubles out(out_size);
214 +
    init_posixct(out, dt_tz);
215 +
    return out;
216 +
  }
203 217
204 218
  std::vector<R_xlen_t> sizes
205 219
                        {year.size(), month.size(), yday.size(), mday.size(),
@@ -217,20 +231,20 @@
Loading
217 231
    loop_hour = sizes[5] == N, loop_minute = sizes[6] == N, loop_second = sizes[7] == N,
218 232
    loop_dt = dt.size() == N;
219 233
220 -
  if (sizes[0] > 1 && !loop_year) Rcpp::stop("C_update_dt: Invalid size of 'year' vector");
221 -
  if (sizes[1] > 1 && !loop_month) Rcpp::stop("C_update_dt: Invalid size of 'month' vector");
222 -
  if (sizes[2] > 1 && !loop_yday) Rcpp::stop("C_update_dt: Invalid size of 'yday' vector");
223 -
  if (sizes[3] > 1 && !loop_mday) Rcpp::stop("C_update_dt: Invalid size of 'mday' vector");
224 -
  if (sizes[4] > 1 && !loop_wday) Rcpp::stop("C_update_dt: Invalid size of 'wday' vector");
225 -
  if (sizes[5] > 1 && !loop_hour) Rcpp::stop("C_update_dt: Invalid size of 'hour' vector");
226 -
  if (sizes[6] > 1 && !loop_minute) Rcpp::stop("C_update_dt: Invalid size of 'minute' vector");
227 -
  if (sizes[7] > 1 && !loop_second) Rcpp::stop("C_update_dt: Invalid size of 'second' vector");
234 +
  if (sizes[0] > 1 && !loop_year) cpp11::stop("C_update_dt: Invalid size of 'year' vector");
235 +
  if (sizes[1] > 1 && !loop_month) cpp11::stop("C_update_dt: Invalid size of 'month' vector");
236 +
  if (sizes[2] > 1 && !loop_yday) cpp11::stop("C_update_dt: Invalid size of 'yday' vector");
237 +
  if (sizes[3] > 1 && !loop_mday) cpp11::stop("C_update_dt: Invalid size of 'mday' vector");
238 +
  if (sizes[4] > 1 && !loop_wday) cpp11::stop("C_update_dt: Invalid size of 'wday' vector");
239 +
  if (sizes[5] > 1 && !loop_hour) cpp11::stop("C_update_dt: Invalid size of 'hour' vector");
240 +
  if (sizes[6] > 1 && !loop_minute) cpp11::stop("C_update_dt: Invalid size of 'minute' vector");
241 +
  if (sizes[7] > 1 && !loop_second) cpp11::stop("C_update_dt: Invalid size of 'second' vector");
228 242
229 243
  if (dt.size() > 1 && !loop_dt)
230 -
    Rcpp::stop("C_update_dt: length of dt vector must be 1 or match the length of updating vectors");
244 +
    cpp11::stop("C_update_dt: length of dt vector must be 1 or match the length of updating vectors");
231 245
232 246
  if (do_yday + do_mday + do_wday > 1)
233 -
    Rcpp::stop("Conflicting days input, only one of yday, mday and wday must be supplied");
247 +
    cpp11::stop("Conflicting days input, only one of yday, mday and wday must be supplied");
234 248
235 249
  std::string tzfrom = tz_from_tzone_attr(dt);
236 250
  cctz::time_zone tzone1;
@@ -245,7 +259,8 @@
Loading
245 259
  }
246 260
  load_tz_or_fail(tzto, tzone2, "CCTZ: Unrecognized tzone: \"%s\"");
247 261
248 -
  Rcpp::NumericVector out(N);
262 +
  cpp11::writable::doubles out(N);
263 +
  init_posixct(out, tzto.c_str());
249 264
250 265
  // all vectors are either size N or 1
251 266
  for (R_xlen_t i = 0; i < N; i++)
@@ -319,19 +334,19 @@
Loading
319 334
320 335
    }
321 336
322 -
  return Rcpp::newDatetimeVector(out, tzto.c_str());
337 +
  return out;
323 338
324 339
}
325 340
326 -
// [[Rcpp::export]]
327 -
Rcpp::newDatetimeVector C_force_tz(const Rcpp::NumericVector dt,
328 -
                                   const Rcpp::CharacterVector tz,
329 -
                                   const bool roll = false) {
341 +
[[cpp11::register]]
342 +
cpp11::writable::doubles C_force_tz(const cpp11::doubles& dt,
343 +
                                    const cpp11::strings& tz,
344 +
                                    const bool roll) {
330 345
  // roll: logical, if `true`, and `time` falls into the DST-break, assume the
331 346
  // next valid civil time, otherwise return NA
332 347
333 348
  if (tz.size() != 1)
334 -
    Rcpp::stop("`tz` argument must be a single character string");
349 +
    cpp11::stop("`tz` argument must be a single character string");
335 350
336 351
  std::string tzfrom_name = tz_from_tzone_attr(dt);
337 352
  std::string tzto_name(tz[0]);
@@ -343,7 +358,8 @@
Loading
343 358
  /* std::cout << "TZ to:" << tzto.name() << std::endl; */
344 359
345 360
  size_t n = dt.size();
346 -
  Rcpp::NumericVector out(n);
361 +
  cpp11::writable::doubles out(n);
362 +
  init_posixct(out, tzto_name.c_str());
347 363
348 364
  for (size_t i = 0; i < n; i++)
349 365
    {
@@ -358,23 +374,23 @@
Loading
358 374
      out[i] = get_secs_from_civil_lookup(cl2, tzfrom, tp1, ct1, roll, rem);
359 375
    }
360 376
361 -
  return Rcpp::newDatetimeVector(out, tzto_name.c_str());
377 +
  return out;
362 378
}
363 379
364 380
365 -
// [[Rcpp::export]]
366 -
Rcpp::newDatetimeVector C_force_tzs(const Rcpp::NumericVector dt,
367 -
                                    const Rcpp::CharacterVector tzs,
368 -
                                    const Rcpp::CharacterVector tz_out,
369 -
                                    const bool roll = false) {
381 +
[[cpp11::register]]
382 +
cpp11::writable::doubles C_force_tzs(const cpp11::doubles& dt,
383 +
                                     const cpp11::strings& tzs,
384 +
                                     const cpp11::strings& tz_out,
385 +
                                     const bool roll) {
370 386
  // roll: logical, if `true`, and `time` falls into the DST-break, assume the
371 387
  // next valid civil time, otherwise return NA
372 388
373 389
  if (tz_out.size() != 1)
374 -
    Rcpp::stop("In 'tzout' argument must be of length 1");
390 +
    cpp11::stop("In 'tzout' argument must be of length 1");
375 391
376 392
  if (tzs.size() != dt.size())
377 -
    Rcpp::stop("In 'C_force_tzs' tzs and dt arguments must be of the same length");
393 +
    cpp11::stop("In 'C_force_tzs' tzs and dt arguments must be of the same length");
378 394
379 395
  std::string tzfrom_name = tz_from_tzone_attr(dt);
380 396
  std::string tzout_name(tz_out[0]);
@@ -385,7 +401,8 @@
Loading
385 401
386 402
  std::string tzto_old_name("not-a-tz");
387 403
  size_t n = dt.size();
388 -
  Rcpp::NumericVector out(n);
404 +
  cpp11::writable::doubles out(n);
405 +
  init_posixct(out, tzout_name.c_str());
389 406
390 407
  for (size_t i = 0; i < n; i++)
391 408
    {
@@ -407,22 +424,22 @@
Loading
407 424
408 425
    }
409 426
410 -
  return Rcpp::newDatetimeVector(out, tzout_name.c_str());
427 +
  return out;
411 428
}
412 429
413 -
// [[Rcpp::export]]
414 -
Rcpp::NumericVector C_local_time(const Rcpp::NumericVector dt,
415 -
                                 const Rcpp::CharacterVector tzs) {
430 +
[[cpp11::register]]
431 +
cpp11::writable::doubles C_local_time(const cpp11::doubles& dt,
432 +
                                      const cpp11::strings& tzs) {
416 433
417 434
  if (tzs.size() != dt.size())
418 -
    Rcpp::stop("`tzs` and `dt` arguments must be of the same length");
435 +
    cpp11::stop("`tzs` and `dt` arguments must be of the same length");
419 436
420 437
  std::string tzfrom_name = tz_from_tzone_attr(dt);
421 438
  std::string tzto_old_name("not-a-tz");
422 439
  cctz::time_zone tzto;
423 440
424 441
  size_t n = dt.size();
425 -
  Rcpp::NumericVector out(n);
442 +
  cpp11::writable::doubles out(n);
426 443
427 444
  for (size_t i = 0; i < n; i++)
428 445
    {
Files Coverage
R 79.91%
src 71.75%
Project Totals (65 files) 76.31%
1
comment: false
2

3
coverage:
4
  status:
5
    project:
6
      default:
7
        target: auto
8
        threshold: 1%
9
        informational: true
10
    patch:
11
      default:
12
        target: auto
13
        threshold: 1%
14
        informational: true
Sunburst
The inner-most circle is the entire project, moving away from the center are folders then, finally, a single file. The size and color of each slice is representing the number of statements and the coverage, respectively.
Icicle
The top section represents the entire project. Proceeding with folders and finally individual files. The size and color of each slice is representing the number of statements and the coverage, respectively.
Grid
Each block represents a single file in the project. The size and color of each block is represented by the number of statements and the coverage, respectively.
Loading