1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
|
match_lengths <- function(x, y) {
n.x <- length(x)
n.y <- length(y)
n.max <- max(n.x, n.y)
n.min <- min(n.x, n.y)
if (n.max %% n.min != 0L) {
stop("longer object length is not a multiple of shorter object length")
} else {
if (n.x < n.y) {
x <- rep(x, length.out = n.y)
} else {
y <- rep(y, length.out = n.x)
}
}
list(x, y)
}
recognize <- function(x) {
recognized <- c("POSIXt", "POSIXlt", "POSIXct", "yearmon", "yearqtr", "Date")
if (all(class(x) %in% recognized))
return(TRUE)
return(FALSE)
}
standardise_date_names <- function(x) {
dates <- c("second", "minute", "hour", "mday", "wday", "yday", "day", "week", "month", "year", "tz")
y <- gsub("(.)s$", "\\1", x)
res <- dates[pmatch(y, dates)]
if (any(is.na(res))) {
stop("Invalid unit name: ", paste(x[is.na(res)], collapse = ", "),
call. = FALSE)
}
res
}
standardise_difftime_names <- function(x) {
dates <- c("secs", "mins", "hours", "days", "weeks")
y <- gsub("(.)s$", "\\1", x)
y <- substr(y, 1, 3)
res <- dates[pmatch(y, dates)]
if (any(is.na(res))) {
stop("Invalid difftime name: ", paste(x[is.na(res)], collapse = ", "),
call. = FALSE)
}
res
}
standardise_period_names <- function(x) {
dates <- c("second", "minute", "hour", "day", "week", "month", "year",
## these ones are used for rounding only
"bimonth", "quarter", "halfyear", "season")
y <- gsub("(.)s$", "\\1", x)
y <- substr(y, 1, 3)
res <- dates[pmatch(y, dates)]
if (any(is.na(res))) {
stop("Invalid period name: ", paste(x[is.na(res)], collapse = ", "),
call. = FALSE)
}
res
}
standardise_lt_names <- function(x) {
if (length(x) == 0L)
stop("No unit names supplied.")
dates <- c("sec", "min", "hour", "day", "mday", "wday", "yday", "mon", "year", "tz")
y <- gsub("(.)s$", "\\1", x)
y <- substr(y, 1, 3)
res <- dates[pmatch(y, dates)]
if (any(is.na(res))) {
stop("Invalid unit name: ", paste(x[is.na(res)], collapse = ", "),
call. = FALSE)
}
res
}
## return list(n=nr_units, unit="unit_name")
parse_period_unit <- function(unit) {
if (length(unit) > 1) {
warning("Unit argument longer than 1. Taking first element.")
unit <- unit[[1]]
}
p <- .Call(C_parse_period, as.character(unit))
if (!is.na(p[[1]])) {
period_units <- c("second", "minute", "hour", "day", "week", "month", "year")
wp <- which(p > 0)
if (length(wp) > 1) {
## Fractional units are actually supported but only when it leads to one
## final unit.
stop("Cannot't parse heterogenuous or fractional units larger than one minute.")
}
list(n = p[wp], unit = period_units[wp])
} else {
## this part is for backward compatibility and allows for bimonth, halfyear
## and quarter
m <- regexpr(" *(?<n>[0-9.,]+)? *(?<unit>[^ \t\n]+)", unit[[1]], perl = T)
if (m > 0) {
## should always match
nms <- attr(m, "capture.names")
nms <- nms[nzchar(nms)]
start <- attr(m, "capture.start")
end <- start + attr(m, "capture.length") - 1L
n <- if (end[[1]] >= start[[1]]) {
as.integer(str_sub(unit, start[[1]], end[[1]]))
} else {
1
}
unit <- str_sub(unit, start[[2]], end[[2]])
list(n = n, unit = unit)
} else {
stop(sprintf("Invalid unit specification '%s'", unit))
}
}
}
undefined_arithmetic <- function(e1, e2) {
msg <- sprintf("Arithmetic operators undefined for '%s' and '%s' classes:
convert one to numeric or a matching time-span class.", class(e1), class(e2))
stop(msg)
}
date_to_posix <- function(date, tz = "UTC") {
utc <- .POSIXct(unclass(date) * 86400, tz = "UTC")
if (tz == "UTC") utc
else force_tz(utc, tz)
}
|