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