1
#include "warp.h"
2
#include "utils.h"
3
#include "divmod.h"
4
#include <stdint.h> // For int64_t (especially on Windows)
5

6
// Helpers defined at the bottom of the file
7
static void validate_every(int every);
8
static void validate_origin(SEXP origin);
9
static int origin_to_days_from_epoch(SEXP origin);
10
static int64_t origin_to_seconds_from_epoch(SEXP origin);
11
static int64_t origin_to_milliseconds_from_epoch(SEXP origin);
12
static inline int64_t guarded_floor(double x);
13
static inline int64_t guarded_floor_to_millisecond(double x);
14

15
// -----------------------------------------------------------------------------
16

17
static SEXP warp_distance_year(SEXP x, int every, SEXP origin);
18
static SEXP warp_distance_quarter(SEXP x, int every, SEXP origin);
19
static SEXP warp_distance_month(SEXP x, int every, SEXP origin);
20
static SEXP warp_distance_week(SEXP x, int every, SEXP origin);
21
static SEXP warp_distance_yweek(SEXP x, int every, SEXP origin);
22
static SEXP warp_distance_mweek(SEXP x, int every, SEXP origin);
23
static SEXP warp_distance_day(SEXP x, int every, SEXP origin);
24
static SEXP warp_distance_yday(SEXP x, int every, SEXP origin);
25
static SEXP warp_distance_mday(SEXP x, int every, SEXP origin);
26
static SEXP warp_distance_hour(SEXP x, int every, SEXP origin);
27
static SEXP warp_distance_minute(SEXP x, int every, SEXP origin);
28
static SEXP warp_distance_second(SEXP x, int every, SEXP origin);
29
static SEXP warp_distance_millisecond(SEXP x, int every, SEXP origin);
30

31
// [[ include("warp.h") ]]
32 1
SEXP warp_distance(SEXP x, enum warp_period_type type, int every, SEXP origin) {
33 1
  validate_origin(origin);
34 1
  validate_every(every);
35

36 1
  if (time_class_type(x) == warp_class_unknown) {
37 1
    r_error("warp_distance", "`x` must inherit from 'Date', 'POSIXct', or 'POSIXlt'.");
38
  }
39

40 1
  if (origin == R_NilValue) {
41 1
    origin = PROTECT(get_origin_epoch_in_time_zone(x));
42
  } else {
43 1
    x = PROTECT(convert_time_zone(x, origin));
44
  }
45

46
  SEXP out;
47

48 1
  switch (type) {
49 1
  case warp_period_year: out = PROTECT(warp_distance_year(x, every, origin)); break;
50 1
  case warp_period_quarter: out = PROTECT(warp_distance_quarter(x, every, origin)); break;
51 1
  case warp_period_month: out = PROTECT(warp_distance_month(x, every, origin)); break;
52 1
  case warp_period_week: out = PROTECT(warp_distance_week(x, every, origin)); break;
53 1
  case warp_period_yweek: out = PROTECT(warp_distance_yweek(x, every, origin)); break;
54 1
  case warp_period_mweek: out = PROTECT(warp_distance_mweek(x, every, origin)); break;
55 1
  case warp_period_day: out = PROTECT(warp_distance_day(x, every, origin)); break;
56 1
  case warp_period_yday: out = PROTECT(warp_distance_yday(x, every, origin)); break;
57 1
  case warp_period_mday: out = PROTECT(warp_distance_mday(x, every, origin)); break;
58 1
  case warp_period_hour: out = PROTECT(warp_distance_hour(x, every, origin)); break;
59 1
  case warp_period_minute: out = PROTECT(warp_distance_minute(x, every, origin)); break;
60 1
  case warp_period_second: out = PROTECT(warp_distance_second(x, every, origin)); break;
61 1
  case warp_period_millisecond: out = PROTECT(warp_distance_millisecond(x, every, origin)); break;
62 0
  default: r_error("warp_distance", "Internal error: unknown `type`.");
63
  }
64

65 1
  UNPROTECT(2);
66 1
  return out;
67
}
68

69
// [[ register() ]]
70 1
SEXP warp_warp_distance(SEXP x, SEXP period, SEXP every, SEXP origin) {
71 1
  enum warp_period_type type = as_period_type(period);
72 1
  int every_ = pull_every(every);
73 1
  return warp_distance(x, type, every_, origin);
74
}
75

76
// -----------------------------------------------------------------------------
77

78 1
static SEXP warp_distance_year(SEXP x, int every, SEXP origin) {
79 1
  int n_prot = 0;
80

81 1
  bool needs_offset = (origin != R_NilValue);
82

83
  int origin_offset;
84

85 1
  if (needs_offset) {
86 1
    SEXP origin_offset_sexp = PROTECT_N(get_year_offset(origin), &n_prot);
87 1
    origin_offset = INTEGER(origin_offset_sexp)[0];
88

89 1
    if (origin_offset == NA_INTEGER) {
90 1
      r_error("warp_distance_year", "`origin` cannot be `NA`.");
91
    }
92
  }
93

94 1
  bool needs_every = (every != 1);
95

96 1
  SEXP year = PROTECT_N(get_year_offset(x), &n_prot);
97 1
  int* p_year = INTEGER(year);
98

99 1
  R_xlen_t n_out = Rf_xlength(year);
100

101 1
  SEXP out = PROTECT_N(Rf_allocVector(REALSXP, n_out), &n_prot);
102 1
  double* p_out = REAL(out);
103

104 1
  for (R_xlen_t i = 0; i < n_out; ++i) {
105 1
    int elt = p_year[i];
106

107 1
    if (elt == NA_INTEGER) {
108 1
      p_out[i] = NA_REAL;
109 1
      continue;
110
    }
111

112 1
    if (needs_offset) {
113 1
      elt -= origin_offset;
114
    }
115

116 1
    if (!needs_every) {
117 1
      p_out[i] = elt;
118 1
      continue;
119
    }
120

121 1
    if (elt < 0) {
122 1
      p_out[i] = (elt - (every - 1)) / every;
123
    } else {
124 1
      p_out[i] = elt / every;
125
    }
126
  }
127

128 1
  UNPROTECT(n_prot);
129 1
  return out;
130
}
131

132
// -----------------------------------------------------------------------------
133

134 1
static SEXP warp_distance_quarter(SEXP x, int every, SEXP origin) {
135 1
  return warp_distance_month(x, every * 3, origin);
136
}
137

138
// -----------------------------------------------------------------------------
139

140 1
static SEXP warp_distance_month(SEXP x, int every, SEXP origin) {
141 1
  int n_prot = 0;
142

143 1
  bool needs_offset = (origin != R_NilValue);
144

145
  int origin_offset;
146

147 1
  if (needs_offset) {
148 1
    SEXP origin_offset_sexp = PROTECT_N(get_month_offset(origin), &n_prot);
149 1
    origin_offset = INTEGER(origin_offset_sexp)[0];
150

151 1
    if (origin_offset == NA_INTEGER) {
152 1
      r_error("warp_distance_month", "`origin` cannot be `NA`.");
153
    }
154
  }
155

156 1
  bool needs_every = (every != 1);
157

158 1
  SEXP month = PROTECT_N(get_month_offset(x), &n_prot);
159 1
  const int* p_month = INTEGER_RO(month);
160

161 1
  R_xlen_t size = Rf_xlength(month);
162

163 1
  SEXP out = PROTECT_N(Rf_allocVector(REALSXP, size), &n_prot);
164 1
  double* p_out = REAL(out);
165

166 1
  for (R_xlen_t i = 0; i < size; ++i) {
167 1
    int elt = p_month[i];
168

169 1
    if (elt == NA_INTEGER) {
170 1
      p_out[i] = NA_REAL;
171 1
      continue;
172
    }
173

174 1
    if (needs_offset) {
175 1
      elt -= origin_offset;
176
    }
177

178 1
    if (!needs_every) {
179 1
      p_out[i] = elt;
180 1
      continue;
181
    }
182

183 1
    if (elt < 0) {
184 1
      elt = (elt - (every - 1)) / every;
185
    } else {
186 1
      elt = elt / every;
187
    }
188

189 1
    p_out[i] = elt;
190
  }
191

192 1
  UNPROTECT(n_prot);
193 1
  return out;
194
}
195

196
// -----------------------------------------------------------------------------
197

198 1
static SEXP warp_distance_week(SEXP x, int every, SEXP origin) {
199 1
  return warp_distance_day(x, every * 7, origin);
200
}
201

202
// -----------------------------------------------------------------------------
203

204 1
static SEXP warp_distance_yweek(SEXP x, int every, SEXP origin) {
205 1
  if (every > 52) {
206 1
    r_error(
207
      "warp_distance_yweek",
208
      "The maximum allowed value of `every` for `period = 'yweek'` is 52."
209
    );
210
  }
211

212 1
  return warp_distance_yday(x, every * 7, origin);
213
}
214

215
// -----------------------------------------------------------------------------
216

217 1
static SEXP warp_distance_mweek(SEXP x, int every, SEXP origin) {
218 1
  if (every > 4) {
219 1
    r_error(
220
      "warp_distance_mweek",
221
      "The maximum allowed value of `every` for `period = 'mweek'` is 4."
222
    );
223
  }
224

225 1
  return warp_distance_mday(x, every * 7, origin);
226
}
227

228
// -----------------------------------------------------------------------------
229

230 1
static SEXP warp_distance_day(SEXP x, int every, SEXP origin) {
231 1
  int n_prot = 0;
232

233 1
  bool needs_offset = (origin != R_NilValue);
234

235
  int origin_offset;
236

237 1
  if (needs_offset) {
238 1
    SEXP origin_offset_sexp = PROTECT_N(get_day_offset(origin), &n_prot);
239 1
    origin_offset = INTEGER(origin_offset_sexp)[0];
240

241 1
    if (origin_offset == NA_INTEGER) {
242 0
      r_error("warp_distance_day", "`origin` cannot be `NA`.");
243
    }
244
  }
245

246 1
  bool needs_every = (every != 1);
247

248 1
  SEXP day = PROTECT_N(get_day_offset(x), &n_prot);
249 1
  const int* p_day = INTEGER_RO(day);
250

251 1
  R_xlen_t size = Rf_xlength(day);
252

253 1
  SEXP out = PROTECT_N(Rf_allocVector(REALSXP, size), &n_prot);
254 1
  double* p_out = REAL(out);
255

256 1
  for (R_xlen_t i = 0; i < size; ++i) {
257 1
    int elt = p_day[i];
258

259 1
    if (elt == NA_INTEGER) {
260 1
      p_out[i] = NA_REAL;
261 1
      continue;
262
    }
263

264 1
    if (needs_offset) {
265 1
      elt -= origin_offset;
266
    }
267

268 1
    if (!needs_every) {
269 1
      p_out[i] = elt;
270 1
      continue;
271
    }
272

273 1
    if (elt < 0) {
274 1
      elt = (elt - (every - 1)) / every;
275
    } else {
276 1
      elt = elt / every;
277
    }
278

279 1
    p_out[i] = elt;
280
  }
281

282 1
  UNPROTECT(n_prot);
283 1
  return out;
284
}
285

286
// -----------------------------------------------------------------------------
287

288
static SEXP date_warp_distance_yday(SEXP x, int every, SEXP origin);
289
static SEXP posixct_warp_distance_yday(SEXP x, int every, SEXP origin);
290
static SEXP posixlt_warp_distance_yday(SEXP x, int every, SEXP origin);
291

292 1
static SEXP warp_distance_yday(SEXP x, int every, SEXP origin) {
293 1
  if (every > 364) {
294 1
    r_error(
295
      "warp_distance_yday",
296
      "The maximum allowed value of `every` for `period = 'yday'` is 364."
297
    );
298
  }
299

300 1
  switch (time_class_type(x)) {
301 1
  case warp_class_date: return date_warp_distance_yday(x, every, origin);
302 1
  case warp_class_posixct: return posixct_warp_distance_yday(x, every, origin);
303 1
  case warp_class_posixlt: return posixlt_warp_distance_yday(x, every, origin);
304 0
  default: r_error("warp_distance_yday", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x)));
305
  }
306
}
307

308

309
static SEXP int_date_warp_distance_yday(SEXP x, int every, SEXP origin);
310
static SEXP dbl_date_warp_distance_yday(SEXP x, int every, SEXP origin);
311

312 1
static SEXP date_warp_distance_yday(SEXP x, int every, SEXP origin) {
313 1
  switch (TYPEOF(x)) {
314 1
  case INTSXP: return int_date_warp_distance_yday(x, every, origin);
315 1
  case REALSXP: return dbl_date_warp_distance_yday(x, every, origin);
316 0
  default: r_error("date_warp_distance_yday", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x)));
317
  }
318
}
319

320

321 1
static SEXP posixct_warp_distance_yday(SEXP x, int every, SEXP origin) {
322 1
  x = PROTECT(as_posixlt_from_posixct(x));
323 1
  SEXP out = posixlt_warp_distance_yday(x, every, origin);
324 1
  UNPROTECT(1);
325 1
  return out;
326
}
327

328
#define DAYS_IN_YEAR 365
329
#define DAYS_IN_LEAP_YEAR 366
330
#define is_leap_year(year) ((((year) % 4) == 0 && ((year) % 100) != 0) || ((year) % 400) == 0)
331

332
static int compute_yday_distance(int days_since_epoch,
333
                                 int year_offset,
334
                                 int yday,
335
                                 int origin_year_offset,
336
                                 int origin_yday,
337
                                 int origin_leap,
338
                                 int units_in_leap_year,
339
                                 int units_in_non_leap_year,
340
                                 int leap_years_before_and_including_origin_year,
341
                                 int every);
342

343
static inline int days_before_year(int year_offset);
344

345 1
static SEXP posixlt_warp_distance_yday(SEXP x, int every, SEXP origin) {
346 1
  SEXP year = VECTOR_ELT(x, 5);
347 1
  SEXP yday = VECTOR_ELT(x, 7);
348

349 1
  if (TYPEOF(year) != INTSXP) {
350 0
    r_error(
351
      "posixlt_warp_distance_yday",
352
      "Internal error: The 6th element of the POSIXlt object should be an integer."
353
    );
354
  }
355

356 1
  if (TYPEOF(yday) != INTSXP) {
357 0
    r_error(
358
      "posixlt_warp_distance_yday",
359
      "Internal error: The 8th element of the POSIXlt object should be an integer."
360
    );
361
  }
362

363 1
  int* p_year = INTEGER(year);
364 1
  int* p_yday = INTEGER(yday);
365

366 1
  R_xlen_t size = Rf_xlength(year);
367

368 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
369 1
  double* p_out = REAL(out);
370

371 1
  int units_in_non_leap_year = (DAYS_IN_YEAR - 1) / every + 1;
372 1
  int units_in_leap_year = (DAYS_IN_LEAP_YEAR - 1) / every + 1;
373

374 1
  struct warp_yday_components origin_components = get_origin_yday_components(origin);
375 1
  int origin_year_offset = origin_components.year_offset;
376 1
  int origin_yday = origin_components.yday;
377 1
  bool origin_leap = is_leap_year(origin_year_offset + 1970);
378

379 1
  int leap_years_before_and_including_origin_year =
380 1
    leap_years_before_and_including_year(origin_year_offset);
381

382 1
  for (R_xlen_t i = 0; i < size; ++i) {
383 1
    if (p_year[i] == NA_INTEGER) {
384 1
      p_out[i] = NA_REAL;
385 1
      continue;
386
    }
387

388 1
    int year_offset = p_year[i] - 70;
389 1
    int yday = p_yday[i];
390

391 1
    int days_since_epoch = days_before_year(year_offset) + yday;
392

393 1
    p_out[i] = compute_yday_distance(
394 1
      days_since_epoch,
395 1
      year_offset,
396 1
      yday,
397 1
      origin_year_offset,
398 1
      origin_yday,
399 1
      origin_leap,
400 1
      units_in_leap_year,
401 1
      units_in_non_leap_year,
402 1
      leap_years_before_and_including_origin_year,
403 1
      every
404
    );
405
  }
406

407 1
  UNPROTECT(1);
408 1
  return out;
409
}
410

411 1
static SEXP int_date_warp_distance_yday(SEXP x, int every, SEXP origin) {
412 1
  int* p_x = INTEGER(x);
413

414 1
  R_xlen_t size = Rf_xlength(x);
415

416 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
417 1
  double* p_out = REAL(out);
418

419 1
  int units_in_non_leap_year = (DAYS_IN_YEAR - 1) / every + 1;
420 1
  int units_in_leap_year = (DAYS_IN_LEAP_YEAR - 1) / every + 1;
421

422 1
  struct warp_yday_components origin_components = get_origin_yday_components(origin);
423 1
  int origin_year_offset = origin_components.year_offset;
424 1
  int origin_yday = origin_components.yday;
425 1
  bool origin_leap = is_leap_year(origin_year_offset + 1970);
426

427 1
  int leap_years_before_and_including_origin_year =
428 1
    leap_years_before_and_including_year(origin_year_offset);
429

430 1
  for (R_xlen_t i = 0; i < size; ++i) {
431 1
    int elt = p_x[i];
432

433 1
    if (elt == NA_INTEGER) {
434 0
      p_out[i] = NA_REAL;
435 0
      continue;
436
    }
437

438 1
    struct warp_components components = convert_days_to_components(elt);
439

440 1
    p_out[i] = compute_yday_distance(
441 1
      elt,
442 1
      components.year_offset,
443 1
      components.yday,
444 1
      origin_year_offset,
445 1
      origin_yday,
446 1
      origin_leap,
447 1
      units_in_leap_year,
448 1
      units_in_non_leap_year,
449 1
      leap_years_before_and_including_origin_year,
450 1
      every
451
    );
452
  }
453

454 1
  UNPROTECT(1);
455 1
  return out;
456
}
457

458 1
static SEXP dbl_date_warp_distance_yday(SEXP x, int every, SEXP origin) {
459 1
  double* p_x = REAL(x);
460

461 1
  R_xlen_t size = Rf_xlength(x);
462

463 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
464 1
  double* p_out = REAL(out);
465

466 1
  int units_in_non_leap_year = (DAYS_IN_YEAR - 1) / every + 1;
467 1
  int units_in_leap_year = (DAYS_IN_LEAP_YEAR - 1) / every + 1;
468

469 1
  struct warp_yday_components origin_components = get_origin_yday_components(origin);
470 1
  int origin_year_offset = origin_components.year_offset;
471 1
  int origin_yday = origin_components.yday;
472 1
  bool origin_leap = is_leap_year(origin_year_offset + 1970);
473

474 1
  int leap_years_before_and_including_origin_year =
475 1
    leap_years_before_and_including_year(origin_year_offset);
476

477 1
  for (R_xlen_t i = 0; i < size; ++i) {
478 1
    double x_elt = p_x[i];
479

480 1
    if (!R_FINITE(x_elt)) {
481 0
      p_out[i] = NA_REAL;
482 0
      continue;
483
    }
484

485
    // Truncate fractional pieces towards 0
486 1
    int elt = x_elt;
487

488 1
    struct warp_components components = convert_days_to_components(elt);
489

490 1
    p_out[i] = compute_yday_distance(
491 1
      elt,
492 1
      components.year_offset,
493 1
      components.yday,
494 1
      origin_year_offset,
495 1
      origin_yday,
496 1
      origin_leap,
497 1
      units_in_leap_year,
498 1
      units_in_non_leap_year,
499 1
      leap_years_before_and_including_origin_year,
500 1
      every
501
    );
502
  }
503

504 1
  UNPROTECT(1);
505 1
  return out;
506
}
507

508
#undef DAYS_IN_YEAR
509
#undef DAYS_IN_LEAP_YEAR
510

511
static inline int yday_leap_adjustment(int year_offset, int yday, bool origin_leap);
512

513 1
static int compute_yday_distance(int days_since_epoch,
514
                                 int year_offset,
515
                                 int yday,
516
                                 int origin_year_offset,
517
                                 int origin_yday,
518
                                 int origin_leap,
519
                                 int units_in_leap_year,
520
                                 int units_in_non_leap_year,
521
                                 int leap_years_before_and_including_origin_year,
522
                                 int every) {
523 1
  int origin_yday_adjusted =
524 1
    origin_yday +
525 1
    yday_leap_adjustment(year_offset, yday, origin_leap);
526

527 1
  int last_origin_year_offset = year_offset;
528 1
  if (yday < origin_yday_adjusted) {
529 1
    --last_origin_year_offset;
530
  }
531

532 1
  int last_origin =
533 1
    days_before_year(last_origin_year_offset) +
534 1
    origin_yday +
535 1
    yday_leap_adjustment(last_origin_year_offset, origin_yday, origin_leap);
536

537 1
  int days_since_last_origin = days_since_epoch - last_origin;
538

539 1
  int units_in_year = int_div(days_since_last_origin, every);
540

541 1
  int years_between_origins = last_origin_year_offset - origin_year_offset;
542

543 1
  int leap_years_between_origins =
544 1
    leap_years_before_and_including_year(last_origin_year_offset) -
545 1
    leap_years_before_and_including_origin_year;
546

547 1
  int non_leap_years_between_origins =
548 1
    years_between_origins -
549 1
    leap_years_between_origins;
550

551 1
  int units_between_origins =
552 1
    units_in_leap_year * leap_years_between_origins +
553 1
    units_in_non_leap_year * non_leap_years_between_origins;
554

555 1
  int out = units_between_origins + units_in_year;
556

557 1
  return out;
558
}
559

560
// Returns the number of days between 1970-01-01 and the beginning of the `year`
561
// defined as the number of `year_offset` from 1970, 0-based
562
#define YEARS_FROM_0001_01_01_TO_EPOCH 1969
563
#define DAYS_FROM_0001_01_01_TO_EPOCH 719162
564

565 1
static inline int days_before_year(int year_offset) {
566 1
  int year = year_offset + YEARS_FROM_0001_01_01_TO_EPOCH;
567

568 1
  int days = year * 365 +
569 1
    int_div(year, 4) -
570 1
    int_div(year, 100) +
571 1
    int_div(year, 400);
572

573 1
  days -= DAYS_FROM_0001_01_01_TO_EPOCH;
574

575 1
  return days;
576
}
577

578
#undef YEARS_FROM_0001_01_01_TO_EPOCH
579
#undef DAYS_FROM_0001_01_01_TO_EPOCH
580

581 1
static inline int yday_leap_adjustment(int year_offset, int yday, bool origin_leap) {
582
  // No adjustment to make if before or equal to Feb 28th
583 1
  if (yday < 58) {
584 1
    return 0;
585
  }
586

587 1
  int year = year_offset + 1970;
588

589 1
  bool year_is_leap = is_leap_year(year);
590

591 1
  if (origin_leap) {
592 1
    if (year_is_leap) {
593 1
      return 0;
594
    } else {
595 1
      return -1;
596
    }
597
  } else {
598 1
    if (year_is_leap) {
599 1
      return 1;
600
    } else {
601 1
      return 0;
602
    }
603
  }
604
}
605

606
#undef is_leap_year
607

608
// -----------------------------------------------------------------------------
609

610
static SEXP date_warp_distance_mday(SEXP x, int every, SEXP origin);
611
static SEXP posixct_warp_distance_mday(SEXP x, int every, SEXP origin);
612
static SEXP posixlt_warp_distance_mday(SEXP x, int every, SEXP origin);
613

614 1
static SEXP warp_distance_mday(SEXP x, int every, SEXP origin) {
615 1
  if (every > 30) {
616 1
    r_error(
617
      "warp_distance_mday",
618
      "The maximum allowed value of `every` for `period = 'mday'` is 30."
619
    );
620
  }
621

622 1
  switch (time_class_type(x)) {
623 1
  case warp_class_date: return date_warp_distance_mday(x, every, origin);
624 1
  case warp_class_posixct: return posixct_warp_distance_mday(x, every, origin);
625 1
  case warp_class_posixlt: return posixlt_warp_distance_mday(x, every, origin);
626 0
  default: r_error("warp_distance_mday", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x)));
627
  }
628
}
629

630

631
static SEXP int_date_warp_distance_mday(SEXP x, int every, SEXP origin);
632
static SEXP dbl_date_warp_distance_mday(SEXP x, int every, SEXP origin);
633

634 1
static SEXP date_warp_distance_mday(SEXP x, int every, SEXP origin) {
635 1
  switch (TYPEOF(x)) {
636 1
  case INTSXP: return int_date_warp_distance_mday(x, every, origin);
637 1
  case REALSXP: return dbl_date_warp_distance_mday(x, every, origin);
638 0
  default: r_error("date_warp_distance_mday", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x)));
639
  }
640
}
641

642

643 1
static SEXP posixct_warp_distance_mday(SEXP x, int every, SEXP origin) {
644 1
  x = PROTECT(as_posixlt_from_posixct(x));
645 1
  SEXP out = posixlt_warp_distance_mday(x, every, origin);
646 1
  UNPROTECT(1);
647 1
  return out;
648
}
649

650
#define is_leap_year(year) ((((year) % 4) == 0 && ((year) % 100) != 0) || ((year) % 400) == 0)
651

652
static inline void fill_units_per_month(int* x, int every);
653
static inline void fill_units_per_month_leap(int* x, int every);
654
static inline int units_per_year(int* x);
655
static inline int units_up_to_month(int month, const int* units_in_month, int every);
656

657
static inline int compute_mday_distance(int day,
658
                                        int month,
659
                                        int year_offset,
660
                                        int origin_year_offset,
661
                                        int units_per_year_leap_year,
662
                                        int units_per_year_non_leap_year,
663
                                        int* units_per_month_leap_year,
664
                                        int* units_per_month_non_leap_year,
665
                                        int units_up_to_origin_month,
666
                                        int leap_years_before_and_including_origin_year,
667
                                        int every);
668

669 1
static SEXP posixlt_warp_distance_mday(SEXP x, int every, SEXP origin) {
670 1
  SEXP year = VECTOR_ELT(x, 5);
671 1
  SEXP month = VECTOR_ELT(x, 4);
672 1
  SEXP day = VECTOR_ELT(x, 3);
673

674 1
  if (TYPEOF(year) != INTSXP) {
675 0
    r_error(
676
      "posixlt_warp_distance_mday",
677
      "Internal error: The 5th element of the POSIXlt object should be an integer."
678
    );
679
  }
680

681 1
  if (TYPEOF(month) != INTSXP) {
682 0
    r_error(
683
      "posixlt_warp_distance_mday",
684
      "Internal error: The 4th element of the POSIXlt object should be an integer."
685
    );
686
  }
687

688 1
  if (TYPEOF(day) != INTSXP) {
689 0
    r_error(
690
      "posixlt_warp_distance_mday",
691
      "Internal error: The 3rd element of the POSIXlt object should be an integer."
692
    );
693
  }
694

695 1
  int* p_year = INTEGER(year);
696 1
  int* p_month = INTEGER(month);
697 1
  int* p_day = INTEGER(day);
698

699 1
  R_xlen_t size = Rf_xlength(year);
700

701 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
702 1
  double* p_out = REAL(out);
703

704
  int units_per_month_non_leap_year[12];
705
  int units_per_month_leap_year[12];
706

707 1
  fill_units_per_month(units_per_month_non_leap_year, every);
708 1
  fill_units_per_month_leap(units_per_month_leap_year, every);
709

710 1
  int units_per_year_non_leap_year = units_per_year(units_per_month_non_leap_year);
711 1
  int units_per_year_leap_year = units_per_year(units_per_month_leap_year);
712

713 1
  struct warp_mday_components origin_components = get_origin_mday_components(origin);
714 1
  int origin_year_offset = origin_components.year_offset;
715 1
  int origin_year = origin_year_offset + 1970;
716 1
  int origin_month = origin_components.month;
717

718 1
  int* units_per_month =
719 1
    is_leap_year(origin_year) ?
720 1
    units_per_month_leap_year :
721 1
    units_per_month_non_leap_year;
722

723 1
  int units_up_to_origin_month = units_up_to_month(
724 1
    origin_month,
725 1
    units_per_month,
726 1
    every
727
  );
728

729 1
  int leap_years_before_and_including_origin_year =
730 1
    leap_years_before_and_including_year(origin_year_offset);
731

732 1
  for (R_xlen_t i = 0; i < size; ++i) {
733 1
    int year_offset = p_year[i];
734 1
    int month = p_month[i];
735 1
    int day = p_day[i];
736

737 1
    if (year_offset == NA_INTEGER) {
738 1
      p_out[i] = NA_REAL;
739 1
      continue;
740
    }
741

742 1
    year_offset -= 70;
743 1
    day -= 1;
744

745 1
    p_out[i] = compute_mday_distance(
746 1
      day,
747 1
      month,
748 1
      year_offset,
749 1
      origin_year_offset,
750 1
      units_per_year_leap_year,
751 1
      units_per_year_non_leap_year,
752 1
      units_per_month_leap_year,
753 1
      units_per_month_non_leap_year,
754 1
      units_up_to_origin_month,
755 1
      leap_years_before_and_including_origin_year,
756 1
      every
757
    );
758
  }
759

760 1
  UNPROTECT(1);
761 1
  return out;
762
}
763

764 1
static SEXP int_date_warp_distance_mday(SEXP x, int every, SEXP origin) {
765 1
  int* p_x = INTEGER(x);
766

767 1
  R_xlen_t size = Rf_xlength(x);
768

769 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
770 1
  double* p_out = REAL(out);
771

772
  int units_per_month_non_leap_year[12];
773
  int units_per_month_leap_year[12];
774

775 1
  fill_units_per_month(units_per_month_non_leap_year, every);
776 1
  fill_units_per_month_leap(units_per_month_leap_year, every);
777

778 1
  int units_per_year_non_leap_year = units_per_year(units_per_month_non_leap_year);
779 1
  int units_per_year_leap_year = units_per_year(units_per_month_leap_year);
780

781 1
  struct warp_mday_components origin_components = get_origin_mday_components(origin);
782 1
  int origin_year_offset = origin_components.year_offset;
783 1
  int origin_year = origin_year_offset + 1970;
784 1
  int origin_month = origin_components.month;
785

786 1
  int* units_per_month =
787 1
    is_leap_year(origin_year) ?
788 0
    units_per_month_leap_year :
789 1
    units_per_month_non_leap_year;
790

791 1
  int units_up_to_origin_month = units_up_to_month(
792 1
    origin_month,
793 1
    units_per_month,
794 1
    every
795
  );
796

797 1
  int leap_years_before_and_including_origin_year =
798 1
    leap_years_before_and_including_year(origin_year_offset);
799

800 1
  for (R_xlen_t i = 0; i < size; ++i) {
801 1
    int elt = p_x[i];
802

803 1
    if (elt == NA_INTEGER) {
804 0
      p_out[i] = NA_REAL;
805 0
      continue;
806
    }
807

808 1
    struct warp_components components = convert_days_to_components(elt);
809

810 1
    p_out[i] = compute_mday_distance(
811 1
      components.day,
812 1
      components.month,
813 1
      components.year_offset,
814 1
      origin_year_offset,
815 1
      units_per_year_leap_year,
816 1
      units_per_year_non_leap_year,
817 1
      units_per_month_leap_year,
818 1
      units_per_month_non_leap_year,
819 1
      units_up_to_origin_month,
820 1
      leap_years_before_and_including_origin_year,
821 1
      every
822
    );
823
  }
824

825 1
  UNPROTECT(1);
826 1
  return out;
827
}
828

829 1
static SEXP dbl_date_warp_distance_mday(SEXP x, int every, SEXP origin) {
830 1
  double* p_x = REAL(x);
831

832 1
  R_xlen_t size = Rf_xlength(x);
833

834 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
835 1
  double* p_out = REAL(out);
836

837
  int units_per_month_non_leap_year[12];
838
  int units_per_month_leap_year[12];
839

840 1
  fill_units_per_month(units_per_month_non_leap_year, every);
841 1
  fill_units_per_month_leap(units_per_month_leap_year, every);
842

843 1
  int units_per_year_non_leap_year = units_per_year(units_per_month_non_leap_year);
844 1
  int units_per_year_leap_year = units_per_year(units_per_month_leap_year);
845

846 1
  struct warp_mday_components origin_components = get_origin_mday_components(origin);
847 1
  int origin_year_offset = origin_components.year_offset;
848 1
  int origin_year = origin_year_offset + 1970;
849 1
  int origin_month = origin_components.month;
850

851 1
  int* units_per_month =
852 1
    is_leap_year(origin_year) ?
853 0
    units_per_month_leap_year :
854 1
    units_per_month_non_leap_year;
855

856 1
  int units_up_to_origin_month = units_up_to_month(
857 1
    origin_month,
858 1
    units_per_month,
859 1
    every
860
  );
861

862 1
  int leap_years_before_and_including_origin_year =
863 1
    leap_years_before_and_including_year(origin_year_offset);
864

865 1
  for (R_xlen_t i = 0; i < size; ++i) {
866 1
    double x_elt = p_x[i];
867

868 1
    if (!R_FINITE(x_elt)) {
869 0
      p_out[i] = NA_REAL;
870 0
      continue;
871
    }
872

873
    // Truncate fractional pieces towards 0
874 1
    int elt = x_elt;
875

876 1
    struct warp_components components = convert_days_to_components(elt);
877

878 1
    p_out[i] = compute_mday_distance(
879 1
      components.day,
880 1
      components.month,
881 1
      components.year_offset,
882 1
      origin_year_offset,
883 1
      units_per_year_leap_year,
884 1
      units_per_year_non_leap_year,
885 1
      units_per_month_leap_year,
886 1
      units_per_month_non_leap_year,
887 1
      units_up_to_origin_month,
888 1
      leap_years_before_and_including_origin_year,
889 1
      every
890
    );
891
  }
892

893 1
  UNPROTECT(1);
894 1
  return out;
895
}
896

897 1
static inline int compute_mday_distance(int day,
898
                                        int month,
899
                                        int year_offset,
900
                                        int origin_year_offset,
901
                                        int units_per_year_leap_year,
902
                                        int units_per_year_non_leap_year,
903
                                        int* units_per_month_leap_year,
904
                                        int* units_per_month_non_leap_year,
905
                                        int units_up_to_origin_month,
906
                                        int leap_years_before_and_including_origin_year,
907
                                        int every) {
908

909 1
  int years_between = year_offset - origin_year_offset;
910

911 1
  int leap_years_between =
912 1
    leap_years_before_and_including_year(year_offset) -
913 1
    leap_years_before_and_including_origin_year;
914

915 1
  int non_leap_years_between =
916 1
    years_between -
917 1
    leap_years_between;
918

919 1
  int units_between_years =
920 1
    leap_years_between * units_per_year_leap_year +
921 1
    non_leap_years_between * units_per_year_non_leap_year;
922

923 1
  int year = year_offset + 1970;
924 1
  bool is_leap = is_leap_year(year);
925

926 1
  int* units_per_month =
927 1
    is_leap ?
928 1
    units_per_month_leap_year :
929 1
    units_per_month_non_leap_year;
930

931 1
  int units_up_to_elt_month = units_up_to_month(
932 1
    month,
933 1
    units_per_month,
934 1
    every
935
  );
936

937 1
  int units_in_month = day / every;
938

939 1
  int out =
940 1
    units_between_years -
941 1
    units_up_to_origin_month +
942 1
    units_up_to_elt_month +
943 1
    units_in_month;
944

945 1
  return out;
946
}
947

948
#undef is_leap_year
949

950
static const int DAYS_IN_MONTH[12] = {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31};
951
static const int DAYS_IN_MONTH_LEAP[12] = {31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31};
952

953 1
static inline void fill_units_per_month(int* x, int every) {
954 1
  for (int i = 0; i < 12; ++i) {
955 1
    x[i] = (DAYS_IN_MONTH[i] - 1) / every + 1;
956
  }
957
}
958

959 1
static inline void fill_units_per_month_leap(int* x, int every) {
960 1
  for (int i = 0; i < 12; ++i) {
961 1
    x[i] = (DAYS_IN_MONTH_LEAP[i] - 1) / every + 1;
962
  }
963
}
964

965 1
static inline int units_per_year(int* x) {
966 1
  int out = 0;
967

968 1
  for (int i = 0; i < 12; ++i) {
969 1
    out += x[i];
970
  }
971

972 1
  return out;
973
}
974

975 1
static inline int units_up_to_month(int month, const int* units_per_month, int every) {
976 1
  int out = 0;
977

978 1
  for (int i = 0; i < month; ++i) {
979 1
    out += units_per_month[i];
980
  }
981

982 1
  return out;
983
}
984

985
// -----------------------------------------------------------------------------
986

987
static SEXP date_warp_distance_hour(SEXP x, int every, SEXP origin);
988
static SEXP posixct_warp_distance_hour(SEXP x, int every, SEXP origin);
989
static SEXP posixlt_warp_distance_hour(SEXP x, int every, SEXP origin);
990

991 1
static SEXP warp_distance_hour(SEXP x, int every, SEXP origin) {
992 1
  switch (time_class_type(x)) {
993 1
  case warp_class_date: return date_warp_distance_hour(x, every, origin);
994 1
  case warp_class_posixct: return posixct_warp_distance_hour(x, every, origin);
995 1
  case warp_class_posixlt: return posixlt_warp_distance_hour(x, every, origin);
996 0
  default: r_error("warp_distance_hour", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x)));
997
  }
998
}
999

1000

1001
static SEXP int_date_warp_distance_hour(SEXP x, int every, SEXP origin);
1002
static SEXP dbl_date_warp_distance_hour(SEXP x, int every, SEXP origin);
1003

1004 1
static SEXP date_warp_distance_hour(SEXP x, int every, SEXP origin) {
1005 1
  switch (TYPEOF(x)) {
1006 1
  case INTSXP: return int_date_warp_distance_hour(x, every, origin);
1007 1
  case REALSXP: return dbl_date_warp_distance_hour(x, every, origin);
1008 0
  default: r_error("date_warp_distance_hour", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x)));
1009
  }
1010
}
1011

1012

1013
static SEXP int_posixct_warp_distance_hour(SEXP x, int every, SEXP origin);
1014
static SEXP dbl_posixct_warp_distance_hour(SEXP x, int every, SEXP origin);
1015

1016 1
static SEXP posixct_warp_distance_hour(SEXP x, int every, SEXP origin) {
1017 1
  switch (TYPEOF(x)) {
1018 1
  case INTSXP: return int_posixct_warp_distance_hour(x, every, origin);
1019 1
  case REALSXP: return dbl_posixct_warp_distance_hour(x, every, origin);
1020 0
  default: r_error("posixct_warp_distance_hour", "Unknown `POSIXct` type %s.", Rf_type2char(TYPEOF(x)));
1021
  }
1022
}
1023

1024

1025 1
static SEXP posixlt_warp_distance_hour(SEXP x, int every, SEXP origin) {
1026 1
  x = PROTECT(as_datetime(x));
1027 1
  SEXP out = PROTECT(posixct_warp_distance_hour(x, every, origin));
1028

1029 1
  UNPROTECT(2);
1030 1
  return out;
1031
}
1032

1033

1034
#define HOURS_IN_DAY 24
1035

1036 1
static SEXP int_date_warp_distance_hour(SEXP x, int every, SEXP origin) {
1037 1
  R_xlen_t size = Rf_xlength(x);
1038

1039 1
  int* p_x = INTEGER(x);
1040

1041 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
1042 1
  double* p_out = REAL(out);
1043

1044 1
  bool needs_every = (every != 1);
1045

1046 1
  bool needs_offset = (origin != R_NilValue);
1047
  int origin_offset;
1048

1049 1
  if (needs_offset) {
1050 1
    origin_offset = origin_to_days_from_epoch(origin);
1051
  }
1052

1053 1
  for (R_xlen_t i = 0; i < size; ++i) {
1054 1
    int elt = p_x[i];
1055

1056 1
    if (elt == NA_INTEGER) {
1057 1
      p_out[i] = NA_REAL;
1058 1
      continue;
1059
    }
1060

1061 1
    if (needs_offset) {
1062 1
      elt -= origin_offset;
1063
    }
1064

1065 1
    elt *= HOURS_IN_DAY;
1066

1067 1
    if (!needs_every) {
1068 1
      p_out[i] = elt;
1069 1
      continue;
1070
    }
1071

1072 1
    if (elt < 0) {
1073 1
      elt = (elt - (every - 1)) / every;
1074
    } else {
1075 1
      elt = elt / every;
1076
    }
1077

1078 1
    p_out[i] = elt;
1079
  }
1080

1081 1
  UNPROTECT(1);
1082 1
  return out;
1083
}
1084

1085 1
static SEXP dbl_date_warp_distance_hour(SEXP x, int every, SEXP origin) {
1086 1
  R_xlen_t size = Rf_xlength(x);
1087

1088 1
  double* p_x = REAL(x);
1089

1090 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
1091 1
  double* p_out = REAL(out);
1092

1093 1
  bool needs_every = (every != 1);
1094

1095 1
  bool needs_offset = (origin != R_NilValue);
1096
  int origin_offset;
1097

1098 1
  if (needs_offset) {
1099 1
    origin_offset = origin_to_days_from_epoch(origin);
1100
  }
1101

1102 1
  for (R_xlen_t i = 0; i < size; ++i) {
1103 1
    double x_elt = p_x[i];
1104

1105 1
    if (!R_FINITE(x_elt)) {
1106 1
      p_out[i] = NA_REAL;
1107 1
      continue;
1108
    }
1109

1110
    // Truncate to completely ignore fractional Date parts
1111 1
    int elt = x_elt;
1112

1113 1
    if (needs_offset) {
1114 1
      elt -= origin_offset;
1115
    }
1116

1117 1
    elt *= HOURS_IN_DAY;
1118

1119 1
    if (!needs_every) {
1120 1
      p_out[i] = elt;
1121 1
      continue;
1122
    }
1123

1124 1
    if (elt < 0) {
1125 1
      elt = (elt - (every - 1)) / every;
1126
    } else {
1127 1
      elt = elt / every;
1128
    }
1129

1130 1
    p_out[i] = elt;
1131
  }
1132

1133 1
  UNPROTECT(1);
1134 1
  return out;
1135
}
1136

1137
#undef HOURS_IN_DAY
1138

1139
#define SECONDS_IN_HOUR 3600
1140

1141 1
static SEXP int_posixct_warp_distance_hour(SEXP x, int every, SEXP origin) {
1142 1
  R_xlen_t size = Rf_xlength(x);
1143

1144 1
  bool needs_every = (every != 1);
1145

1146 1
  bool needs_offset = (origin != R_NilValue);
1147
  int64_t origin_offset;
1148

1149 1
  if (needs_offset) {
1150 1
    origin_offset = origin_to_seconds_from_epoch(origin);
1151
  }
1152

1153 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
1154 1
  double* p_out = REAL(out);
1155

1156 1
  int* p_x = INTEGER(x);
1157

1158 1
  for (R_xlen_t i = 0; i < size; ++i) {
1159 1
    int x_elt = p_x[i];
1160

1161 1
    if (x_elt == NA_INTEGER) {
1162 1
      p_out[i] = NA_REAL;
1163 1
      continue;
1164
    }
1165

1166
    // Avoid overflow
1167 1
    int64_t elt = x_elt;
1168

1169 1
    if (needs_offset) {
1170 1
      elt -= origin_offset;
1171
    }
1172

1173 1
    if (elt < 0) {
1174 1
      elt = (elt - (SECONDS_IN_HOUR - 1)) / SECONDS_IN_HOUR;
1175
    } else {
1176 1
      elt = elt / SECONDS_IN_HOUR;
1177
    }
1178

1179 1
    if (!needs_every) {
1180 1
      p_out[i] = elt;
1181 1
      continue;
1182
    }
1183

1184 1
    if (elt < 0) {
1185 1
      elt = (elt - (every - 1)) / every;
1186
    } else {
1187 1
      elt = elt / every;
1188
    }
1189

1190 1
    p_out[i] = elt;
1191
  }
1192

1193 1
  UNPROTECT(1);
1194 1
  return out;
1195
}
1196

1197 1
static SEXP dbl_posixct_warp_distance_hour(SEXP x, int every, SEXP origin) {
1198 1
  R_xlen_t size = Rf_xlength(x);
1199

1200 1
  bool needs_every = (every != 1);
1201

1202 1
  bool needs_offset = (origin != R_NilValue);
1203
  int64_t origin_offset;
1204

1205 1
  if (needs_offset) {
1206 1
    origin_offset = origin_to_seconds_from_epoch(origin);
1207
  }
1208

1209 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
1210 1
  double* p_out = REAL(out);
1211

1212 1
  double* p_x = REAL(x);
1213

1214 1
  for (R_xlen_t i = 0; i < size; ++i) {
1215 1
    double x_elt = p_x[i];
1216

1217 1
    if (!R_FINITE(x_elt)) {
1218 1
      p_out[i] = NA_REAL;
1219 1
      continue;
1220
    }
1221

1222 1
    int64_t elt = guarded_floor(x_elt);
1223

1224 1
    if (needs_offset) {
1225 1
      elt -= origin_offset;
1226
    }
1227

1228 1
    if (elt < 0) {
1229 1
      elt = (elt - (SECONDS_IN_HOUR - 1)) / SECONDS_IN_HOUR;
1230
    } else {
1231 1
      elt = elt / SECONDS_IN_HOUR;
1232
    }
1233

1234 1
    if (!needs_every) {
1235 1
      p_out[i] = elt;
1236 1
      continue;
1237
    }
1238

1239 1
    if (elt < 0) {
1240 1
      elt = (elt - (every - 1)) / every;
1241
    } else {
1242 1
      elt = elt / every;
1243
    }
1244

1245 1
    p_out[i] = elt;
1246
  }
1247

1248 1
  UNPROTECT(1);
1249 1
  return out;
1250
}
1251

1252
#undef SECONDS_IN_HOUR
1253

1254
// -----------------------------------------------------------------------------
1255

1256
static SEXP date_warp_distance_minute(SEXP x, int every, SEXP origin);
1257
static SEXP posixct_warp_distance_minute(SEXP x, int every, SEXP origin);
1258
static SEXP posixlt_warp_distance_minute(SEXP x, int every, SEXP origin);
1259

1260 1
static SEXP warp_distance_minute(SEXP x, int every, SEXP origin) {
1261 1
  switch (time_class_type(x)) {
1262 1
  case warp_class_date: return date_warp_distance_minute(x, every, origin);
1263 1
  case warp_class_posixct: return posixct_warp_distance_minute(x, every, origin);
1264 1
  case warp_class_posixlt: return posixlt_warp_distance_minute(x, every, origin);
1265 0
  default: r_error("warp_distance_minute", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x)));
1266
  }
1267
}
1268

1269

1270
static SEXP int_date_warp_distance_minute(SEXP x, int every, SEXP origin);
1271
static SEXP dbl_date_warp_distance_minute(SEXP x, int every, SEXP origin);
1272

1273 1
static SEXP date_warp_distance_minute(SEXP x, int every, SEXP origin) {
1274 1
  switch (TYPEOF(x)) {
1275 1
  case INTSXP: return int_date_warp_distance_minute(x, every, origin);
1276 1
  case REALSXP: return dbl_date_warp_distance_minute(x, every, origin);
1277 0
  default: r_error("date_warp_distance_minute", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x)));
1278
  }
1279
}
1280

1281

1282
static SEXP int_posixct_warp_distance_minute(SEXP x, int every, SEXP origin);
1283
static SEXP dbl_posixct_warp_distance_minute(SEXP x, int every, SEXP origin);
1284

1285 1
static SEXP posixct_warp_distance_minute(SEXP x, int every, SEXP origin) {
1286 1
  switch (TYPEOF(x)) {
1287 1
  case INTSXP: return int_posixct_warp_distance_minute(x, every, origin);
1288 1
  case REALSXP: return dbl_posixct_warp_distance_minute(x, every, origin);
1289 0
  default: r_error("posixct_warp_distance_minute", "Unknown `POSIXct` type %s.", Rf_type2char(TYPEOF(x)));
1290
  }
1291
}
1292

1293

1294 1
static SEXP posixlt_warp_distance_minute(SEXP x, int every, SEXP origin) {
1295 1
  x = PROTECT(as_datetime(x));
1296 1
  SEXP out = PROTECT(posixct_warp_distance_minute(x, every, origin));
1297

1298 1
  UNPROTECT(2);
1299 1
  return out;
1300
}
1301

1302

1303
#define MINUTES_IN_DAY 1440
1304

1305 1
static SEXP int_date_warp_distance_minute(SEXP x, int every, SEXP origin) {
1306 1
  R_xlen_t size = Rf_xlength(x);
1307

1308 1
  int* p_x = INTEGER(x);
1309

1310 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
1311 1
  double* p_out = REAL(out);
1312

1313 1
  bool needs_every = (every != 1);
1314

1315 1
  bool needs_offset = (origin != R_NilValue);
1316
  int origin_offset;
1317

1318 1
  if (needs_offset) {
1319 1
    origin_offset = origin_to_days_from_epoch(origin);
1320
  }
1321

1322 1
  for (R_xlen_t i = 0; i < size; ++i) {
1323 1
    int elt = p_x[i];
1324

1325 1
    if (elt == NA_INTEGER) {
1326 1
      p_out[i] = NA_REAL;
1327 1
      continue;
1328
    }
1329

1330 1
    if (needs_offset) {
1331 1
      elt -= origin_offset;
1332
    }
1333

1334 1
    elt *= MINUTES_IN_DAY;
1335

1336 1
    if (!needs_every) {
1337 1
      p_out[i] = elt;
1338 1
      continue;
1339
    }
1340

1341 1
    if (elt < 0) {
1342 1
      elt = (elt - (every - 1)) / every;
1343
    } else {
1344 1
      elt = elt / every;
1345
    }
1346

1347 1
    p_out[i] = elt;
1348
  }
1349

1350 1
  UNPROTECT(1);
1351 1
  return out;
1352
}
1353

1354 1
static SEXP dbl_date_warp_distance_minute(SEXP x, int every, SEXP origin) {
1355 1
  R_xlen_t size = Rf_xlength(x);
1356

1357 1
  double* p_x = REAL(x);
1358

1359 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
1360 1
  double* p_out = REAL(out);
1361

1362 1
  bool needs_every = (every != 1);
1363

1364 1
  bool needs_offset = (origin != R_NilValue);
1365
  int origin_offset;
1366

1367 1
  if (needs_offset) {
1368 1
    origin_offset = origin_to_days_from_epoch(origin);
1369
  }
1370

1371 1
  for (R_xlen_t i = 0; i < size; ++i) {
1372 1
    double x_elt = p_x[i];
1373

1374 1
    if (!R_FINITE(x_elt)) {
1375 1
      p_out[i] = NA_REAL;
1376 1
      continue;
1377
    }
1378

1379
    // Truncate to completely ignore fractional Date parts
1380 1
    int elt = x_elt;
1381

1382 1
    if (needs_offset) {
1383 1
      elt -= origin_offset;
1384
    }
1385

1386 1
    elt *= MINUTES_IN_DAY;
1387

1388 1
    if (!needs_every) {
1389 1
      p_out[i] = elt;
1390 1
      continue;
1391
    }
1392

1393 1
    if (elt < 0) {
1394 1
      elt = (elt - (every - 1)) / every;
1395
    } else {
1396 1
      elt = elt / every;
1397
    }
1398

1399 1
    p_out[i] = elt;
1400
  }
1401

1402 1
  UNPROTECT(1);
1403 1
  return out;
1404
}
1405

1406
#undef MINUTES_IN_DAY
1407

1408
#define SECONDS_IN_MINUTE 60
1409

1410 1
static SEXP int_posixct_warp_distance_minute(SEXP x, int every, SEXP origin) {
1411 1
  R_xlen_t size = Rf_xlength(x);
1412

1413 1
  bool needs_every = (every != 1);
1414

1415 1
  bool needs_offset = (origin != R_NilValue);
1416
  int64_t origin_offset;
1417

1418 1
  if (needs_offset) {
1419 1
    origin_offset = origin_to_seconds_from_epoch(origin);
1420
  }
1421

1422 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
1423 1
  double* p_out = REAL(out);
1424

1425 1
  int* p_x = INTEGER(x);
1426

1427 1
  for (R_xlen_t i = 0; i < size; ++i) {
1428 1
    int x_elt = p_x[i];
1429

1430 1
    if (x_elt == NA_INTEGER) {
1431 1
      p_out[i] = NA_REAL;
1432 1
      continue;
1433
    }
1434

1435
    // Avoid overflow
1436 1
    int64_t elt = x_elt;
1437

1438 1
    if (needs_offset) {
1439 1
      elt -= origin_offset;
1440
    }
1441

1442 1
    if (elt < 0) {
1443 1
      elt = (elt - (SECONDS_IN_MINUTE - 1)) / SECONDS_IN_MINUTE;
1444
    } else {
1445 1
      elt = elt / SECONDS_IN_MINUTE;
1446
    }
1447

1448 1
    if (!needs_every) {
1449 1
      p_out[i] = elt;
1450 1
      continue;
1451
    }
1452

1453 1
    if (elt < 0) {
1454 1
      elt = (elt - (every - 1)) / every;
1455
    } else {
1456 1
      elt = elt / every;
1457
    }
1458

1459 1
    p_out[i] = elt;
1460
  }
1461

1462 1
  UNPROTECT(1);
1463 1
  return out;
1464
}
1465

1466 1
static SEXP dbl_posixct_warp_distance_minute(SEXP x, int every, SEXP origin) {
1467 1
  R_xlen_t size = Rf_xlength(x);
1468

1469 1
  bool needs_every = (every != 1);
1470

1471 1
  bool needs_offset = (origin != R_NilValue);
1472
  int64_t origin_offset;
1473

1474 1
  if (needs_offset) {
1475 1
    origin_offset = origin_to_seconds_from_epoch(origin);
1476
  }
1477

1478 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, size));
1479 1
  double* p_out = REAL(out);
1480

1481 1
  double* p_x = REAL(x);
1482

1483 1
  for (R_xlen_t i = 0; i < size; ++i) {
1484 1
    double x_elt = p_x[i];
1485

1486 1
    if (!R_FINITE(x_elt)) {
1487 1
      p_out[i] = NA_REAL;
1488 1
      continue;
1489
    }
1490

1491 1
    int64_t elt = guarded_floor(x_elt);
1492

1493 1
    if (needs_offset) {
1494 1
      elt -= origin_offset;
1495
    }
1496

1497 1
    if (elt < 0) {
1498 1
      elt = (elt - (SECONDS_IN_MINUTE - 1)) / SECONDS_IN_MINUTE;
1499
    } else {
1500 1
      elt = elt / SECONDS_IN_MINUTE;
1501
    }
1502

1503 1
    if (!needs_every) {
1504 1
      p_out[i] = elt;
1505 1
      continue;
1506
    }
1507

1508 1
    if (elt < 0) {
1509 1
      elt = (elt - (every - 1)) / every;
1510
    } else {
1511 1
      elt = elt / every;
1512
    }
1513

1514 1
    p_out[i] = elt;
1515
  }
1516

1517 1
  UNPROTECT(1);
1518 1
  return out;
1519
}
1520

1521
#undef SECONDS_IN_MINUTE
1522

1523
// -----------------------------------------------------------------------------
1524

1525
static SEXP date_warp_distance_second(SEXP x, int every, SEXP origin);
1526
static SEXP posixct_warp_distance_second(SEXP x, int every, SEXP origin);
1527
static SEXP posixlt_warp_distance_second(SEXP x, int every, SEXP origin);
1528

1529 1
static SEXP warp_distance_second(SEXP x, int every, SEXP origin) {
1530 1
  switch (time_class_type(x)) {
1531 1
  case warp_class_date: return date_warp_distance_second(x, every, origin);
1532 1
  case warp_class_posixct: return posixct_warp_distance_second(x, every, origin);
1533 1
  case warp_class_posixlt: return posixlt_warp_distance_second(x, every, origin);
1534 0
  default: r_error("warp_distance_second", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x)));
1535
  }
1536
}
1537

1538

1539
static SEXP int_date_warp_distance_second(SEXP x, int every, SEXP origin);
1540
static SEXP dbl_date_warp_distance_second(SEXP x, int every, SEXP origin);
1541

1542 1
static SEXP date_warp_distance_second(SEXP x, int every, SEXP origin) {
1543 1
  switch (TYPEOF(x)) {
1544 1
  case INTSXP: return int_date_warp_distance_second(x, every, origin);
1545 1
  case REALSXP: return dbl_date_warp_distance_second(x, every, origin);
1546 0
  default: r_error("date_warp_distance_second", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x)));
1547
  }
1548
}
1549

1550

1551
static SEXP int_posixct_warp_distance_second(SEXP x, int every, SEXP origin);
1552
static SEXP dbl_posixct_warp_distance_second(SEXP x, int every, SEXP origin);
1553

1554 1
static SEXP posixct_warp_distance_second(SEXP x, int every, SEXP origin) {
1555 1
  switch (TYPEOF(x)) {
1556 1
  case INTSXP: return int_posixct_warp_distance_second(x, every, origin);
1557 1
  case REALSXP: return dbl_posixct_warp_distance_second(x, every, origin);
1558 0
  default: r_error("posixct_warp_distance_second", "Unknown `POSIXct` type %s.", Rf_type2char(TYPEOF(x)));
1559
  }
1560
}
1561

1562

1563 1
static SEXP posixlt_warp_distance_second(SEXP x, int every, SEXP origin) {
1564 1
  x = PROTECT(as_datetime(x));
1565 1
  SEXP out = PROTECT(posixct_warp_distance_second(x, every, origin));
1566

1567 1
  UNPROTECT(2);
1568 1
  return out;
1569
}
1570

1571

1572
#define SECONDS_IN_DAY 86400
1573

1574 1
static SEXP int_date_warp_distance_second(SEXP x, int every, SEXP origin) {
1575 1
  R_xlen_t x_size = Rf_xlength(x);
1576

1577 1
  int* p_x = INTEGER(x);
1578

1579 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size));
1580 1
  double* p_out = REAL(out);
1581

1582 1
  bool needs_every = (every != 1);
1583

1584 1
  bool needs_offset = (origin != R_NilValue);
1585
  int origin_offset;
1586

1587 1
  if (needs_offset) {
1588 1
    origin_offset = origin_to_days_from_epoch(origin);
1589
  }
1590

1591 1
  for (R_xlen_t i = 0; i < x_size; ++i) {
1592 1
    int x_elt = p_x[i];
1593

1594 1
    if (x_elt == NA_INTEGER) {
1595 1
      p_out[i] = NA_REAL;
1596 1
      continue;
1597
    }
1598

1599
    // Avoid overflow
1600 1
    int64_t elt = x_elt;
1601

1602 1
    if (needs_offset) {
1603 1
      elt -= origin_offset;
1604
    }
1605

1606 1
    elt *= SECONDS_IN_DAY;
1607

1608 1
    if (!needs_every) {
1609 1
      p_out[i] = elt;
1610 1
      continue;
1611
    }
1612

1613 1
    if (elt < 0) {
1614 1
      elt = (elt - (every - 1)) / every;
1615
    } else {
1616 1
      elt = elt / every;
1617
    }
1618

1619 1
    p_out[i] = elt;
1620
  }
1621

1622 1
  UNPROTECT(1);
1623 1
  return out;
1624
}
1625

1626 1
static SEXP dbl_date_warp_distance_second(SEXP x, int every, SEXP origin) {
1627 1
  R_xlen_t x_size = Rf_xlength(x);
1628

1629 1
  double* p_x = REAL(x);
1630

1631 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size));
1632 1
  double* p_out = REAL(out);
1633

1634 1
  bool needs_every = (every != 1);
1635

1636 1
  bool needs_offset = (origin != R_NilValue);
1637
  int origin_offset;
1638

1639 1
  if (needs_offset) {
1640 1
    origin_offset = origin_to_days_from_epoch(origin);
1641
  }
1642

1643 1
  for (R_xlen_t i = 0; i < x_size; ++i) {
1644 1
    double x_elt = p_x[i];
1645

1646 1
    if (!R_FINITE(x_elt)) {
1647 1
      p_out[i] = NA_REAL;
1648 1
      continue;
1649
    }
1650

1651
    // Truncate to completely ignore fractional Date parts
1652
    // `int64_t` to avoid overflow
1653 1
    int64_t elt = x_elt;
1654

1655 1
    if (needs_offset) {
1656 1
      elt -= origin_offset;
1657
    }
1658

1659 1
    elt *= SECONDS_IN_DAY;
1660

1661 1
    if (!needs_every) {
1662 1
      p_out[i] = elt;
1663 1
      continue;
1664
    }
1665

1666 1
    if (elt < 0) {
1667 1
      elt = (elt - (every - 1)) / every;
1668
    } else {
1669 1
      elt = elt / every;
1670
    }
1671

1672 1
    p_out[i] = elt;
1673
  }
1674

1675 1
  UNPROTECT(1);
1676 1
  return out;
1677
}
1678

1679
#undef SECONDS_IN_DAY
1680

1681 1
static SEXP int_posixct_warp_distance_second(SEXP x, int every, SEXP origin) {
1682 1
  R_xlen_t x_size = Rf_xlength(x);
1683

1684 1
  bool needs_every = (every != 1);
1685

1686 1
  bool needs_offset = (origin != R_NilValue);
1687
  int64_t origin_offset;
1688

1689 1
  if (needs_offset) {
1690 1
    origin_offset = origin_to_seconds_from_epoch(origin);
1691
  }
1692

1693 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size));
1694 1
  double* p_out = REAL(out);
1695

1696 1
  int* p_x = INTEGER(x);
1697

1698 1
  for (R_xlen_t i = 0; i < x_size; ++i) {
1699 1
    int x_elt = p_x[i];
1700

1701 1
    if (x_elt == NA_INTEGER) {
1702 1
      p_out[i] = NA_REAL;
1703 1
      continue;
1704
    }
1705

1706
    // Avoid overflow
1707 1
    int64_t elt = x_elt;
1708

1709 1
    if (needs_offset) {
1710 1
      elt -= origin_offset;
1711
    }
1712

1713 1
    if (!needs_every) {
1714 1
      p_out[i] = elt;
1715 1
      continue;
1716
    }
1717

1718 1
    if (elt < 0) {
1719 1
      elt = (elt - (every - 1)) / every;
1720
    } else {
1721 1
      elt = elt / every;
1722
    }
1723

1724 1
    p_out[i] = elt;
1725
  }
1726

1727 1
  UNPROTECT(1);
1728 1
  return out;
1729
}
1730

1731 1
static SEXP dbl_posixct_warp_distance_second(SEXP x, int every, SEXP origin) {
1732 1
  R_xlen_t x_size = Rf_xlength(x);
1733

1734 1
  bool needs_every = (every != 1);
1735

1736 1
  bool needs_offset = (origin != R_NilValue);
1737
  int64_t origin_offset;
1738

1739 1
  if (needs_offset) {
1740 1
    origin_offset = origin_to_seconds_from_epoch(origin);
1741
  }
1742

1743 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size));
1744 1
  double* p_out = REAL(out);
1745

1746 1
  double* p_x = REAL(x);
1747

1748 1
  for (R_xlen_t i = 0; i < x_size; ++i) {
1749 1
    double x_elt = p_x[i];
1750

1751 1
    if (!R_FINITE(x_elt)) {
1752 1
      p_out[i] = NA_REAL;
1753 1
      continue;
1754
    }
1755

1756 1
    int64_t elt = guarded_floor(x_elt);
1757

1758 1
    if (needs_offset) {
1759 1
      elt -= origin_offset;
1760
    }
1761

1762 1
    if (!needs_every) {
1763 1
      p_out[i] = elt;
1764 1
      continue;
1765
    }
1766

1767 1
    if (elt < 0) {
1768 1
      elt = (elt - (every - 1)) / every;
1769
    } else {
1770 1
      elt = elt / every;
1771
    }
1772

1773 1
    p_out[i] = elt;
1774
  }
1775

1776 1
  UNPROTECT(1);
1777 1
  return out;
1778
}
1779

1780
// -----------------------------------------------------------------------------
1781

1782
static SEXP date_warp_distance_millisecond(SEXP x, int every, SEXP origin);
1783
static SEXP posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin);
1784
static SEXP posixlt_warp_distance_millisecond(SEXP x, int every, SEXP origin);
1785

1786 1
static SEXP warp_distance_millisecond(SEXP x, int every, SEXP origin) {
1787 1
  switch (time_class_type(x)) {
1788 1
  case warp_class_date: return date_warp_distance_millisecond(x, every, origin);
1789 1
  case warp_class_posixct: return posixct_warp_distance_millisecond(x, every, origin);
1790 1
  case warp_class_posixlt: return posixlt_warp_distance_millisecond(x, every, origin);
1791 0
  default: r_error("warp_distance_millisecond", "Unknown object with type, %s.", Rf_type2char(TYPEOF(x)));
1792
  }
1793
}
1794

1795

1796
static SEXP int_date_warp_distance_millisecond(SEXP x, int every, SEXP origin);
1797
static SEXP dbl_date_warp_distance_millisecond(SEXP x, int every, SEXP origin);
1798

1799 1
static SEXP date_warp_distance_millisecond(SEXP x, int every, SEXP origin) {
1800 1
  switch (TYPEOF(x)) {
1801 1
  case INTSXP: return int_date_warp_distance_millisecond(x, every, origin);
1802 1
  case REALSXP: return dbl_date_warp_distance_millisecond(x, every, origin);
1803 0
  default: r_error("date_warp_distance_millisecond", "Unknown `Date` type %s.", Rf_type2char(TYPEOF(x)));
1804
  }
1805
}
1806

1807

1808
static SEXP int_posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin);
1809
static SEXP dbl_posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin);
1810

1811 1
static SEXP posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin) {
1812 1
  switch (TYPEOF(x)) {
1813 1
  case INTSXP: return int_posixct_warp_distance_millisecond(x, every, origin);
1814 1
  case REALSXP: return dbl_posixct_warp_distance_millisecond(x, every, origin);
1815 0
  default: r_error("posixct_warp_distance_millisecond", "Unknown `POSIXct` type %s.", Rf_type2char(TYPEOF(x)));
1816
  }
1817
}
1818

1819

1820 1
static SEXP posixlt_warp_distance_millisecond(SEXP x, int every, SEXP origin) {
1821 1
  x = PROTECT(as_datetime(x));
1822 1
  SEXP out = PROTECT(posixct_warp_distance_millisecond(x, every, origin));
1823

1824 1
  UNPROTECT(2);
1825 1
  return out;
1826
}
1827

1828

1829
#define MILLISECONDS_IN_DAY 86400000
1830

1831 1
static SEXP int_date_warp_distance_millisecond(SEXP x, int every, SEXP origin) {
1832 1
  R_xlen_t x_size = Rf_xlength(x);
1833

1834 1
  int* p_x = INTEGER(x);
1835

1836 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size));
1837 1
  double* p_out = REAL(out);
1838

1839 1
  bool needs_every = (every != 1);
1840

1841 1
  bool needs_offset = (origin != R_NilValue);
1842
  int origin_offset;
1843

1844 1
  if (needs_offset) {
1845 1
    origin_offset = origin_to_days_from_epoch(origin);
1846
  }
1847

1848 1
  for (R_xlen_t i = 0; i < x_size; ++i) {
1849 1
    int x_elt = p_x[i];
1850

1851 1
    if (x_elt == NA_INTEGER) {
1852 1
      p_out[i] = NA_REAL;
1853 1
      continue;
1854
    }
1855

1856
    // `int64_t` to avoid overflow
1857 1
    int64_t elt = x_elt;
1858

1859 1
    if (needs_offset) {
1860 1
      elt -= origin_offset;
1861
    }
1862

1863 1
    elt *= MILLISECONDS_IN_DAY;
1864

1865 1
    if (!needs_every) {
1866 1
      p_out[i] = elt;
1867 1
      continue;
1868
    }
1869

1870 1
    if (elt < 0) {
1871 1
      elt = (elt - (every - 1)) / every;
1872
    } else {
1873 1
      elt = elt / every;
1874
    }
1875

1876 1
    p_out[i] = elt;
1877
  }
1878

1879 1
  UNPROTECT(1);
1880 1
  return out;
1881
}
1882

1883 1
static SEXP dbl_date_warp_distance_millisecond(SEXP x, int every, SEXP origin) {
1884 1
  R_xlen_t x_size = Rf_xlength(x);
1885

1886 1
  double* p_x = REAL(x);
1887

1888 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size));
1889 1
  double* p_out = REAL(out);
1890

1891 1
  bool needs_every = (every != 1);
1892

1893 1
  bool needs_offset = (origin != R_NilValue);
1894
  int origin_offset;
1895

1896 1
  if (needs_offset) {
1897 1
    origin_offset = origin_to_days_from_epoch(origin);
1898
  }
1899

1900 1
  for (R_xlen_t i = 0; i < x_size; ++i) {
1901 1
    double x_elt = p_x[i];
1902

1903 1
    if (!R_FINITE(x_elt)) {
1904 1
      p_out[i] = NA_REAL;
1905 1
      continue;
1906
    }
1907

1908
    // Truncate to completely ignore fractional Date parts
1909
    // `int64_t` to avoid overflow
1910 1
    int64_t elt = x_elt;
1911

1912 1
    if (needs_offset) {
1913 1
      elt -= origin_offset;
1914
    }
1915

1916 1
    elt *= MILLISECONDS_IN_DAY;
1917

1918 1
    if (!needs_every) {
1919 1
      p_out[i] = elt;
1920 1
      continue;
1921
    }
1922

1923 1
    if (elt < 0) {
1924 1
      elt = (elt - (every - 1)) / every;
1925
    } else {
1926 1
      elt = elt / every;
1927
    }
1928

1929 1
    p_out[i] = elt;
1930
  }
1931

1932 1
  UNPROTECT(1);
1933 1
  return out;
1934
}
1935

1936
#undef MILLISECONDS_IN_DAY
1937

1938
#define MILLISECONDS_IN_SECOND 1000
1939

1940 1
static SEXP int_posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin) {
1941 1
  R_xlen_t x_size = Rf_xlength(x);
1942

1943 1
  bool needs_every = (every != 1);
1944

1945 1
  bool needs_offset = (origin != R_NilValue);
1946
  int64_t origin_offset;
1947

1948 1
  if (needs_offset) {
1949 1
    origin_offset = origin_to_milliseconds_from_epoch(origin);
1950
  }
1951

1952 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size));
1953 1
  double* p_out = REAL(out);
1954

1955 1
  int* p_x = INTEGER(x);
1956

1957 1
  for (R_xlen_t i = 0; i < x_size; ++i) {
1958 1
    int x_elt = p_x[i];
1959

1960 1
    if (x_elt == NA_INTEGER) {
1961 1
      p_out[i] = NA_REAL;
1962 1
      continue;
1963
    }
1964

1965
    // `int64_t` to avoid overflow
1966
    // Note - Have to do `* MILLISECONDS_IN_SECOND` before the
1967
    // offset subtraction because the offset is already in milliseconds
1968 1
    int64_t elt = x_elt * MILLISECONDS_IN_SECOND;
1969

1970 1
    if (needs_offset) {
1971 1
      elt -= origin_offset;
1972
    }
1973

1974 1
    if (!needs_every) {
1975 1
      p_out[i] = elt;
1976 1
      continue;
1977
    }
1978

1979 0
    if (elt < 0) {
1980 0
      elt = (elt - (every - 1)) / every;
1981
    } else {
1982 0
      elt = elt / every;
1983
    }
1984

1985 0
    p_out[i] = elt;
1986
  }
1987

1988 1
  UNPROTECT(1);
1989 1
  return out;
1990
}
1991

1992 1
static SEXP dbl_posixct_warp_distance_millisecond(SEXP x, int every, SEXP origin) {
1993 1
  R_xlen_t x_size = Rf_xlength(x);
1994

1995 1
  bool needs_every = (every != 1);
1996

1997 1
  bool needs_offset = (origin != R_NilValue);
1998
  int64_t origin_offset;
1999

2000 1
  if (needs_offset) {
2001 1
    origin_offset = origin_to_milliseconds_from_epoch(origin);
2002
  }
2003

2004 1
  SEXP out = PROTECT(Rf_allocVector(REALSXP, x_size));
2005 1
  double* p_out = REAL(out);
2006

2007 1
  double* p_x = REAL(x);
2008

2009 1
  for (R_xlen_t i = 0; i < x_size; ++i) {
2010 1
    double x_elt = p_x[i];
2011

2012 1
    if (!R_FINITE(x_elt)) {
2013 1
      p_out[i] = NA_REAL;
2014 1
      continue;
2015
    }
2016

2017 1
    int64_t elt = guarded_floor_to_millisecond(x_elt);
2018

2019 1
    if (needs_offset) {
2020 1
      elt -= origin_offset;
2021
    }
2022

2023 1
    if (!needs_every) {
2024 1
      p_out[i] = elt;
2025 1
      continue;
2026
    }
2027

2028 1
    if (elt < 0) {
2029 1
      elt = (elt - (every - 1)) / every;
2030
    } else {
2031 1
      elt = elt / every;
2032
    }
2033

2034 1
    p_out[i] = elt;
2035
  }
2036

2037 1
  UNPROTECT(1);
2038 1
  return out;
2039
}
2040

2041
#undef MILLISECONDS_IN_SECOND
2042

2043
// -----------------------------------------------------------------------------
2044

2045 1
static void validate_every(int every) {
2046 1
  if (every == NA_INTEGER) {
2047 1
    r_error("validate_every", "`every` must not be `NA`");
2048
  }
2049

2050 1
  if (every <= 0) {
2051 1
    r_error("validate_every", "`every` must be an integer greater than 0, not %i", every);
2052
  }
2053
}
2054

2055 1
static void validate_origin(SEXP origin) {
2056 1
  if (origin == R_NilValue) {
2057 1
    return;
2058
  }
2059

2060 1
  R_len_t n_origin = Rf_length(origin);
2061

2062 1
  if (n_origin != 1) {
2063 1
    r_error("validate_origin", "`origin` must have size 1, not %i.", n_origin);
2064
  }
2065

2066 1
  if (time_class_type(origin) == warp_class_unknown) {
2067 1
    r_error("validate_origin", "`origin` must inherit from 'Date', 'POSIXct', or 'POSIXlt'.");
2068
  }
2069
}
2070

2071
// `as_date()` will always return a double with no fractional component,
2072
// and the double will always fit inside an int
2073 1
static int origin_to_days_from_epoch(SEXP origin) {
2074 1
  origin = PROTECT(as_date(origin));
2075

2076 1
  double out = REAL(origin)[0];
2077

2078 1
  if (!R_FINITE(out)) {
2079 0
    r_error("origin_to_days_from_epoch", "`origin` must not be `NA`.");
2080
  }
2081

2082 1
  UNPROTECT(1);
2083 1
  return (int) out;
2084
}
2085

2086 1
static int64_t origin_to_seconds_from_epoch(SEXP origin) {
2087 1
  origin = PROTECT(as_datetime(origin));
2088

2089 1
  double origin_value = REAL(origin)[0];
2090

2091 1
  if (!R_FINITE(origin_value)) {
2092 1
    r_error("origin_to_seconds_from_epoch", "`origin` must be finite.");
2093
  }
2094

2095 1
  int64_t out = guarded_floor(origin_value);
2096

2097 1
  UNPROTECT(1);
2098 1
  return out;
2099
}
2100

2101 1
static int64_t origin_to_milliseconds_from_epoch(SEXP origin) {
2102 1
  origin = PROTECT(as_datetime(origin));
2103

2104 1
  double origin_value = REAL(origin)[0];
2105

2106 1
  if (!R_FINITE(origin_value)) {
2107 0
    r_error("origin_to_milliseconds_from_epoch", "`origin` must be finite.");
2108
  }
2109

2110 1
  int64_t out = guarded_floor_to_millisecond(origin_value);
2111

2112 1
  UNPROTECT(1);
2113 1
  return out;
2114
}
2115

2116
/*
2117
 * `double` values are represented with 64 bits:
2118
 * - 1 sign bit
2119
 * - 11 exponent bits
2120
 * - 52 significand bits
2121
 *
2122
 * The 52 significand bits are the ones that store the true value, this
2123
 * corresponds to about ~16 significand digits, with everything after
2124
 * that being garbage.
2125
 *
2126
 * Internally doubles are represented with scientific notation to put them in
2127
 * the exponent-significand representation. So the following date, which
2128
 * is represented as a double, really looks like this in scientific notation:
2129
 *
2130
 * unclass(as.POSIXct("2011-05-01 17:55:23.123456"))
2131
 * =
2132
 * 1304286923.1234560013
2133
 * =
2134
 * 1.3042869231234560013e+09
2135
 *                 ^ 16th digit
2136
 *
2137
 * Because only ~16 digits are stable, this is where we draw the line on
2138
 * assuming that the user might have some valuable information stored here.
2139
 * This corresponds to microseconds. Sure, we could use
2140
 * a date that has less digits before the decimal to get more fractional
2141
 * precision (see below) but most dates are in this form: 10 digits before
2142
 * the decimal representing whole seconds, meaning 6 stable digits after it.
2143
 *
2144
 * The other part of the story is that not all floating point numbers can be
2145
 * represented exactly in binary. For example:
2146
 *
2147
 * unclass(as.POSIXct("1969-12-31 23:59:59.998", "UTC"))
2148
 * =
2149
 * -0.002000000000002444267
2150
 *
2151
 * Because of this, `floor()` will give results that (to us) are incorrect if
2152
 * we were to try and floor to milliseconds. We would first times by 1000 to
2153
 * get milliseconds of `-2.000000000002444267`, and then `floor()` would give
2154
 * us -3, not -2 which is the correct group.
2155
 *
2156
 * To get around this, we need to guard against this floating point error. The
2157
 * best way I can come up with is to add a small value before flooring, which
2158
 * would push us into the -1.9999999 range, which would floor correctly.
2159
 *
2160
 * I chose the value of just beyond 1 microsecond because that is generally
2161
 * where the 17th digit falls for most dates
2162
 * (10 digits of whole seconds, 5 of stable fractional seconds). This seems to
2163
 * work well for the millisecond grouping, and we apply it to anywhere that
2164
 * uses seconds "just in case", but it is hard to come up with tests for them.
2165
 */
2166

2167 1
static inline int64_t guarded_floor(double x) {
2168
  // Scale and trim past microseconds
2169 1
  x *= 1e6;
2170 1
  x = trunc(x);
2171 1
  x *= 1e-6;
2172

2173
  // Add guard and floor
2174 1
  x += 1e-7;
2175 1
  x = floor(x);
2176

2177 1
  return (int64_t) x;
2178
}
2179

2180
// The order here is slightly different. We want to convert
2181
// seconds to milliseconds while still guarding correctly.
2182
// - Scale and trim past microseconds
2183
// - Guard while still at the second level to put it on the right decimal
2184
// - Now scale to millisecond and floor
2185

2186 1
static inline int64_t guarded_floor_to_millisecond(double x) {
2187
  // Scale and trim past microseconds
2188 1
  x *= 1e6;
2189 1
  x = trunc(x);
2190 1
  x *= 1e-6;
2191

2192
  // Add guard, scale to milliseconds, and floor
2193 1
  x += 1e-7;
2194 1
  x *= 1e3;
2195 1
  x = floor(x);
2196

2197 1
  return (int64_t) x;
2198
}

Read our documentation on viewing source code .

Loading