1match_lengths <- function(x, y) {
2  n.x <- length(x)
3  n.y <- length(y)
4  n.max <- max(n.x, n.y)
5  n.min <- min(n.x, n.y)
6  if (n.max %% n.min != 0L) {
7    stop("longer object length is not a multiple of shorter object length")
8  } else {
9    if (n.x < n.y) {
10      x <- rep(x, length.out = n.y)
11    } else {
12      y <- rep(y, length.out = n.x)
13    }
14  }
15  list(x, y)
16}
17
18standardise_date_names <- function(x) {
19  dates <- c("second", "minute", "hour", "mday", "wday", "yday", "day", "week", "month", "year", "tz")
20  y <- gsub("(.)s$", "\\1", x)
21  res <- dates[pmatch(y, dates, duplicates.ok = TRUE)]
22  if (any(is.na(res))) {
23    stop("Invalid unit name: ", paste(x[is.na(res)], collapse = ", "),
24      call. = FALSE)
25  }
26  res
27}
28
29standardise_difftime_names <- function(x) {
30  dates <- c("secs", "mins", "hours", "days", "weeks")
31  y <- gsub("(.)s$", "\\1", x)
32  y <- substr(y, 1, 3)
33  res <- dates[pmatch(y, dates, duplicates.ok = TRUE)]
34  if (any(is.na(res))) {
35    stop("Invalid difftime name: ", paste(x[is.na(res)], collapse = ", "),
36      call. = FALSE)
37  }
38  res
39}
40
41standardise_period_names <- function(x) {
42  dates <- c("second", "minute", "hour", "day", "week", "month", "year",
43             ## these ones are used for rounding only
44             "bimonth", "quarter", "halfyear", "season")
45  y <- gsub("(.)s$", "\\1", x)
46  y <- substr(y, 1, 3)
47  res <- dates[pmatch(y, dates)]
48  if (any(is.na(res))) {
49    stop("Invalid period name: ", paste(x[is.na(res)], collapse = ", "),
50      call. = FALSE)
51  }
52  res
53}
54
55standardise_lt_names <- function(x) {
56  if (length(x) == 0L)
57    stop("No unit names supplied.")
58  dates <- c("sec", "min", "hour", "day", "mday", "wday", "yday", "mon", "year", "tz")
59  y <- gsub("(.)s$", "\\1", x)
60  y <- substr(y, 1, 3)
61  res <- dates[pmatch(y, dates)]
62  if (any(is.na(res))) {
63    stop("Invalid unit name: ", paste(x[is.na(res)], collapse = ", "),
64         call. = FALSE)
65  }
66  res
67}
68
69## return list(n=nr_units, unit="unit_name")
70parse_period_unit <- function(unit) {
71
72  if (length(unit) > 1) {
73    warning("Unit argument longer than 1. Taking first element.")
74    unit <- unit[[1]]
75  }
76
77  p <- .Call(C_parse_period, as.character(unit))
78
79  if (!is.na(p[[1]])) {
80
81    period_units <- c("second", "minute", "hour", "day", "week", "month", "year")
82
83    wp <- which(p > 0)
84    if (length(wp) > 1) {
85      ## Fractional units are actually supported but only when it leads to one
86      ## final unit.
87      stop("Cannot't parse heterogenuous or fractional units larger than one minute.")
88    }
89
90    list(n = p[wp], unit = period_units[wp])
91
92  } else {
93    ## this part is for backward compatibility and allows for bimonth, halfyear
94    ## and quarter
95
96    m <- regexpr(" *(?<n>[0-9.,]+)? *(?<unit>[^ \t\n]+)", unit[[1]], perl = T)
97    if (m > 0) {
98      ## should always match
99      nms <- attr(m, "capture.names")
100      nms <- nms[nzchar(nms)]
101      start <- attr(m, "capture.start")
102      end <- start + attr(m, "capture.length") - 1L
103      n <- if (end[[1]] >= start[[1]]) {
104             as.integer(substr(unit, start[[1]], end[[1]]))
105           } else {
106             1
107           }
108      unit <- substr(unit, start[[2]], end[[2]])
109      list(n = n, unit = unit)
110    } else {
111      stop(sprintf("Invalid unit specification '%s'", unit))
112    }
113
114  }
115}
116
117date_to_posix <- function(date, tz = "UTC") {
118  utc <- .POSIXct(unclass(date) * 86400, tz = "UTC")
119  if (is_utc(tz)) utc
120  else force_tz(utc, tz)
121}
122
123# UTC-equivalent timezones can be treated as UTC;
124#   check grep('UTC|GMT', OlsonNames(), value = TRUE)
125is_utc = function(tz) {
126  utc_tz = c("UTC", "GMT", "Etc/UTC", "Etc/GMT", "GMT-0", "GMT+0", "GMT0")
127  if (is.null(tz)) tz = Sys.timezone()
128  return(tz %in% utc_tz)
129}
130
131# minimal custom str_sub function to replicate stringr::str_sub without the full dependency.
132.str_sub <- function(x, start, end, replace_with = "") {
133
134  # get the parts of the string to the left and right of the replacement.
135  start.c = substr(x, 1, start - 1)
136  end.c = substr(x, end + 1, nchar(x))
137
138  # paste with replacement in the middle.
139  x <- paste(start.c, replace_with, end.c, sep = "")
140
141  x
142}
143
144is_verbose <- function() {
145  isTRUE(getOption("lubridate.verbose"))
146}
147
148stop_incompatible_classes <- function(x, y, method) {
149  stop(paste0(
150    "Incompatible classes: <", is(x)[[1]], "> ", method, " <", is(y)[[1]], ">\n"
151  ), call. = FALSE)
152}
153