diff --git a/.Rbuildignore b/.Rbuildignore index fd5f70869cc2bc7216610a243704e8d049865154..8a6f5c1c864d0cb1ac1c1f0d7a5dc17886d45fb7 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -7,4 +7,4 @@ .*\.gitlab-ci.yml$ # Ignore tests when submitting to CRAN ^tests$ - +^CONTRIBUTING\.md$ diff --git a/DESCRIPTION b/DESCRIPTION index d0cf868e2b67b882301f94dea2a1ccd32d373670..fbd0cdfbdd09fd19b37f16547eeda0a63ffe8d2a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,27 +1,33 @@ Package: ClimProjDiags Title: Set of Tools to Compute Various Climate Indices -Version: 0.3.3 +Version: 0.3.4 Authors@R: c( person("BSC-CNS", role = c("aut", "cph")), - person("Victòria", "Agudetse", , "victoria.agudetse@bsc.es", role = c("cre")), person("Nuria", "Perez-Zanon", , "nuria.perez@bsc.es", role = c("aut"), comment = c(ORCID = "0000-0001-8568-3071")), person("An-Chi", "Ho", , "an.ho@bsc.es", role = c("ctb")), + person("Victòria", "Agudetse", , "victoria.agudetse@bsc.es", role = c("cre")), person("Nicolau", "Manubens", , "nicolau.manubens@bsc.es", role = "ctb"), person("Alasdair", "Hunter", , "alasdair.hunter@bsc.es", role = "aut"), person("Louis-Philippe", "Caron", , "louis-philippe.caron@bsc.es", role = "ctb"), - person("Eva", "Rifà", , "eva.rifarovira@bsc.es", role = "ctb")) + person("Eva", "Rifà", , "eva.rifarovira@bsc.es", role = "ctb"), + person("Ulrich", "Drepper", , , role = "ctb"), + person("David", "Bronaugh", , , role = "ctb"), + person("James", "Hiebert", , , role = "ctb")) Description: Set of tools to compute metrics and indices for climate analysis. The package provides functions to compute extreme indices, evaluate the agreement between models and combine theses models into an ensemble. Multi-model time series of climate indices can be computed either after averaging the 2-D fields from different models provided they share a common grid or by combining time series computed on the model native grid. Indices can be assigned weights - and/or combined to construct new indices. + and/or combined to construct new indices. The package makes use of some of the + methods described in: + N. Manubens et al. (2018) . Depends: R (>= 3.2.0) Imports: + graphics, + methods, multiApply (>= 2.0.0), - PCICt, stats Suggests: knitr, @@ -32,6 +38,8 @@ License: GPL-3 URL: https://earth.bsc.es/gitlab/es/ClimProjDiags BugReports: https://earth.bsc.es/gitlab/es/ClimProjDiags/-/issues Encoding: UTF-8 -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 VignetteBuilder: knitr Config/testthat/edition: 3 +NeedsCompilation: yes +SystemRequirements: C++11 diff --git a/NAMESPACE b/NAMESPACE index dd96fe5720228804e4819bd5704fe63ee6a077c0..92d5c9e62f96f8b2b9c1861395d41a13c938fe51 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,6 +17,42 @@ export(Threshold) export(WaveDuration) export(WeightedCells) export(WeightedMean) -import(PCICt) +export(as.PCICt) +import(methods) import(multiApply) +importFrom(graphics,axis) +importFrom(graphics,par) importFrom(stats,quantile) +useDynLib(ClimProjDiags) +S3method(c, PCICt) +S3method(rep, PCICt) +S3method(seq, PCICt) +S3method(trunc, PCICt) +S3method(mean, PCICt) +S3method(range, PCICt) +S3method(julian, PCICt) +S3method(diff, PCICt) +S3method(cut, PCICt) +S3method(is.numeric, PCICt) +S3method(min, PCICt) +S3method(max, PCICt) +S3method(print, PCICt) +S3method(format, PCICt) +S3method(summary, PCICt) +S3method(unique, PCICt) +# S3method(axis, PCICt) +S3method(pretty, PCICt) +export(.PCICt, round.PCICt, as.PCICt, as.PCICt.default, as.character.PCICt, as.PCICt.numeric, as.PCICt.POSIXlt, as.PCICt.POSIXct, as.POSIXlt.PCICt, as.POSIXct.PCICt, "+.PCICt", "-.PCICt", Ops.PCICt, "[.PCICt", "[<-.PCICt") +S3method("+", PCICt) +S3method("-", PCICt) +S3method("[", PCICt) +S3method("[<-", PCICt) +S3method(Ops, PCICt) +S3method(as.PCICt, POSIXct) +S3method(as.PCICt, POSIXlt) +S3method(as.PCICt, default) +S3method(as.PCICt, numeric) +S3method(as.POSIXct, PCICt) +S3method(as.POSIXlt, PCICt) +S3method(as.character, PCICt) +S3method(round, PCICt) diff --git a/R/ArrayToList.R b/R/ArrayToList.R index a36de39393fb1691ac00b798252254a01195fed3..5a394a6b89d1dde95b2ef7208071051dc91a852b 100644 --- a/R/ArrayToList.R +++ b/R/ArrayToList.R @@ -1,7 +1,8 @@ #' Split an array into list by a given array dimension #' #'@description This function splits an array into a list as required by -#'PlotLayout function from package "s2dv" when parameter 'special_args' is used. +#'PlotLayout function from package "s2dv" when parameter 'special_args' is used. +#'See: N. Manubens et al. (2018) <. #'The function ArrayToList allows to add names to the elements of the list in #'two different levels, the 'list' or the 'sublist'. #' @@ -29,8 +30,8 @@ #'class(datalist[[1]]) #'class(datalist[[1]][[1]]) #'str(datalist) -#'@seealso \link[s2dv]{PlotLayout} #'@export + ArrayToList <- function(data, dim, level = 'list', names = NULL) { if (is.null(dim(data))) { stop("Parameter 'data' must be an array or matrix.") diff --git a/R/Climdex.R b/R/Climdex.R index a3e6ea758ae5d17d52d3cb618b3317492d71eb9e..3722c32092f3018181d015889f8b443a0aac7043 100644 --- a/R/Climdex.R +++ b/R/Climdex.R @@ -30,7 +30,6 @@ #'} #' #'@import multiApply -#'@import PCICt #'@examples #'##Example synthetic data: #'data <- 1:(2 * 3 * 372 * 1) diff --git a/R/DailyAno.R b/R/DailyAno.R index f0717d0b96dccd3da407174feae499d50ca5b4d3..96d67faa357a1d9ffad1e0b4c83776530f7d1510 100644 --- a/R/DailyAno.R +++ b/R/DailyAno.R @@ -88,4 +88,4 @@ DailyAno <- function(data, jdays = NULL, dates = NULL, calendar = NULL, na.rm = anomalies[i] <- data[i] - climatology[index] } return(anomalies) -} \ No newline at end of file +} diff --git a/R/Extremes.R b/R/Extremes.R index eab67937e459fc6387e6822237ea96d08275684f..41b5199c00d35f78a62f5a70aa32b7081baed4ef 100644 --- a/R/Extremes.R +++ b/R/Extremes.R @@ -37,7 +37,6 @@ #'the data is reached. The default for fclimdex is FALSE. #' #'@import multiApply -#'@import PCICt #'@examples #'##Example synthetic data: #'data <- 1:(2 * 3 * 310 * 1) diff --git a/R/PCICtFunctions.R b/R/PCICtFunctions.R new file mode 100644 index 0000000000000000000000000000000000000000..eda30bce9f54ace739706a1480e68102c0da02a6 --- /dev/null +++ b/R/PCICtFunctions.R @@ -0,0 +1,861 @@ +#----------------------------------------------------------- +# Auxiliary functions from package PCICt +# (2025-05-03) The package was removed from CRAN. To maintain ClimProjDiags, +# we copy the necessary functions here. +# We will recover the dependency when PCICt is on CRAN again. +#----------------------------------------------------------- +# Package: PCICt +# Version: 0.5-4.4 +# Date: 2023-02-13 +# Title: Implementation of POSIXct Work-Alike for 365 and 360 Day +# Calendars +# Author: David Bronaugh for the Pacific Climate +# Impacts Consortium (PCIC); portions based on code written by +# the R-Core team and Ulrich Drepper. +# Maintainer: James Hiebert +# Depends: R (>= 2.12.0), methods, graphics +# Suggests: RUnit +# Description: Provides a work-alike to R's POSIXct class which implements +# 360- and 365-day calendars in addition to the gregorian calendar. +# License: GPL-2 +# URL: https://www.r-project.org +# NeedsCompilation: yes +# SystemRequirements: C++11 +# Repository: CRAN +#----------------------------------------------------------- + +## Helper functions: + +origin.year <- 1970 +origin.year.POSIXlt <- 1900 +class.list <- c("PCICt") + +setOldClass("PCICt") + +## TODO: +## - S4 class to avoid stripping of attributes? + +PCICt.get.months <- function(cal) { + m.365 <- c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) + m.360 <- c(30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30) + switch(cal, "365"=m.365, "360"=m.360) +} + +dpy.for.cal <- function(cal) { + switch(cal, "365"=365, "360"=360) +} + +clean.cal <- function(cal) { + cal.list <- c("365_day", "365", "noleap", "360_day", "360", "gregorian", "standard", "proleptic_gregorian") + cal.map <- c( "365", "365", "365", "360", "360", "gregorian", "gregorian", "proleptic_gregorian") + if(!cal %in% cal.list) stop(paste("Calendar type not one of", paste(cal.list, sep=", "))) + return(cal.map[cal.list %in% cal]) +} + +.PCICt <- function(x, cal) { + if(missing(cal)) stop("Can't create a PCICt with no calendar type") + cal.cleaned <- clean.cal(cal) + structure(x, cal=cal.cleaned, months=PCICt.get.months(cal.cleaned), class=class.list, dpy=dpy.for.cal(cal.cleaned), tzone="GMT", units="secs") +} + +#'@import methods +#'@noRd +range.PCICt <- function(..., na.rm=FALSE) { + args <- list(...) + stopifnot(length(unique(lapply(args, function(x) { attr(x, "cal") }))) == 1) + args.flat <- unlist(args) + ret <- c(min(args.flat, na.rm=na.rm), max(args.flat, na.rm=na.rm)) + ret <- copy.atts.PCICt(args[[1]], ret) + class(ret) <- class.list + return(ret) +} + +#'@noRd +c.PCICt <- function(..., recursive=FALSE) { + ##stopifnot(length(unique(lapply(..., function(x) { attr(x, "cal") }))) == 1) + cal <- attr(..1, "cal") + .PCICt(c(unlist(lapply(list(...), unclass))), cal) +} + +## Use this to drop the 'units' attribute and unclass the object... +coerceTimeUnit <- function(x) { + as.vector(switch(attr(x,"units"), + secs = x, mins = 60*x, hours = 60*60*x, + days = 60*60*24*x, weeks = 60*60*24*7*x)) +} + +#'@noRd +`+.PCICt` <- function(e1, e2) { + if (nargs() == 1) return(e1) + ## only valid if one of e1 and e2 is a scalar/difftime + if(inherits(e1, "PCICt") && inherits(e2, "PCICt")) + stop("binary '+' is not defined for \"PCICt\" objects") + if (inherits(e1, "difftime")) e1 <- coerceTimeUnit(e1) + if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2) + .PCICt(unclass(e1) + unclass(e2), cal=attr(e1, "cal")) +} + +#'@noRd +`-.PCICt` <- function(e1, e2) { + ## need to drop "units" attribute here + if(!inherits(e1, "PCICt")) + stop("Can only subtract from PCICt objects") + if (nargs() == 1) stop("unary '-' is not defined for \"PCICt\" objects") + if(inherits(e2, "PCICt")) { + stopifnot(attr(e1, "cal") == attr(e2, "cal")) + return(as.difftime(unclass(e1) - unclass(e2), units="secs")) + } + if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2) + if(!is.null(attr(e2, "class"))) + stop("can only subtract numbers from PCICt objects") + .PCICt(unclass(e1) - e2, cal=attr(e1, "cal")) +} + +#'@noRd +Ops.PCICt <- function(e1, e2) { + if (nargs() == 1) + stop(gettextf("unary '%s' not defined for \"PCICt\" objects", + .Generic), domain = NA) + + PCICt.object <- NULL + if(inherits(e1, "PCICt")) + PCICt.object <- e1 + else if(inherits(e2, "PCICt")) + PCICt.object <- e2 + else + stop("Can't use PCICt operators on non-PCICt objects") + + + boolean <- switch(.Generic, "<" = , ">" = , "==" = , + "!=" = , "<=" = , ">=" = TRUE, FALSE) + if (!boolean) + stop(gettextf("'%s' not defined for \"PCICt\" objects", .Generic), + domain = NA) + if(inherits(e1, "POSIXlt") || is.character(e1)) e1 <- as.PCICt(e1, cal=attr(PCICt.object, "cal")) + if(inherits(e2, "POSIXlt") || is.character(e1)) e2 <- as.PCICt(e2, cal=attr(PCICt.object, "cal")) + stopifnot(attr(e1, "cal") == attr(e2, "cal")) + NextMethod(.Generic) +} + +#'@noRd +rep.PCICt <- function(x, ...) { + y <- rep(unclass(x), ...) + .PCICt(y, cal=attr(x, "cal")) +} + +#'@noRd +mean.PCICt <- function(x, ...) { + .PCICt(mean(unclass(x), ...), attr(x, "cal")) +} + +#'@noRd +min.PCICt <- function(x, ...) { + res <- min(unclass(x), ...) + return(copy.atts.PCICt(x, res)) +} + +#'@noRd +max.PCICt <- function(x, ...) { + res <- max(unclass(x), ...) + return(copy.atts.PCICt(x, res)) +} + +#'@noRd +seq.PCICt <- function(from, to, by, length.out = NULL, along.with = NULL, ...) { + if (missing(from)) + stop("'from' must be specified") + if (!inherits(from, "PCICt")) + stop("'from' must be a PCICt object") + if (length(from) != 1L) + stop("'from' must be of length 1") + if (!missing(to)) { + stopifnot(attr(from, "cal") == attr(to, "cal")) + if (!inherits(to, "PCICt")) + stop("'to' must be a PCICt object") + if (length(to) != 1) + stop("'to' must be of length 1") + if(to < from) + stop("'to' must be less than 'from'") + } + if (!missing(along.with)) { + length.out <- length(along.with) + } + else if (!is.null(length.out)) { + if (length(length.out) != 1L) + stop("'length.out' must be of length 1") + length.out <- ceiling(length.out) + } + status <- c(!missing(to), !missing(by), !is.null(length.out)) + if (sum(status) != 2L) + stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified") + if (missing(by)) { + from <- unclass(from) + to <- unclass(to) + res <- seq.int(from, to, length.out = length.out) + return(.PCICt(res, attr(from, "cal"))) + } + if (length(by) != 1L) + stop("'by' must be of length 1") + valid <- 0L + if (inherits(by, "difftime")) { + by <- switch(attr(by, "units"), secs = 1, mins = 60, + hours = 3600, days = 86400, weeks = 7 * 86400) * + unclass(by) + } else if (is.character(by)) { + by2 <- strsplit(by, " ", fixed = TRUE)[[1L]] + if (length(by2) > 2L || length(by2) < 1L) + stop("invalid 'by' string") + valid <- pmatch(by2[length(by2)], c("secs", "mins", "hours", + "days", "weeks", "months", "years", "DSTdays")) + if (is.na(valid)) + stop("invalid string for 'by'") + if (valid <= 5L) { + by <- c(1, 60, 3600, 86400, 7 * 86400)[valid] + if (length(by2) == 2L) + by <- by * as.integer(by2[1L]) + } + else by <- if (length(by2) == 2L) + as.integer(by2[1L]) + else 1 + } + else if (!is.numeric(by)) + stop("invalid mode for 'by'") + if (is.na(by)) + stop("'by' is NA") + if (valid <= 5L) { + from <- unclass(from) + if (!is.null(length.out)) + res <- seq.int(from, by = by, length.out = length.out) + else { + to0 <- unclass(to) + res <- seq.int(0, to0 - from, by) + from + } + return(.PCICt(res, attr(from, "cal"))) + } else { + r1 <- as.POSIXlt(from) + if (valid == 7L) { + if (missing(to)) { + yr <- seq.int(r1$year, by = by, length.out = length.out) + } else { + to0 <- as.POSIXlt(to) + yr <- seq.int(r1$year, to0$year, by) + } + r1$year <- yr + } else if (valid == 6L) { + if (missing(to)) { + mon <- seq.int(r1$mon, by = by, length.out = length.out) + } else { + to0 <- as.POSIXlt(to) + mon <- seq.int(r1$mon, 12 * (to0$year - r1$year) + + to0$mon, by) + } + r1$mon <- mon + } else if (valid == 8L) { + if (!missing(to)) { + length.out <- 2L + floor((unclass(to) - + unclass(from))/86400) + } + r1$mday <- seq.int(r1$mday, by = by, length.out = length.out) + } + r1$isdst <- -1L + res <- as.PCICt(r1, attr(from, "cal")) + if (!missing(to)) { + res <- if (by > 0) + res[res <= to] + else res[res >= to] + } + res + } +} + +#'@noRd +trunc.PCICt <- function(x, units = c("secs", "mins", "hours", "days"), ...) { + units <- match.arg(units) + val <- unclass(x) + round.to <- switch(units, secs = 1, mins = 60, hours = 3600, days = 86400) + val <- floor(val / round.to) * round.to + class(val) <- class(x) + return(copy.atts.PCICt(x, val)) +} + +#'@noRd +round.PCICt <- function (x, digits = c("secs", "mins", "hours", "days")) { + if (is.numeric(digits) && digits == 0) + digits <- "secs" + digits <- match.arg(digits) + x <- x + switch(digits, secs = 0.5, mins = 30, hours = 1800, + days = 43200) + trunc(x, units = digits) +} + +#'@noRd +copy.atts.PCICt <- function(from, to) { + return(structure(to, cal=attr(from, "cal"), months=attr(from, "months"), class=class(from), dpy=attr(from, "dpy"), tzone=attr(from, "tzone"), units=attr(from, "units"))) +} + +#'@noRd +`[.PCICt` <- function(x, ...) { + val <- NextMethod("[") + val <- copy.atts.PCICt(x, val) + class(val) <- class(x) + val +} + +#'@noRd +`[<-.PCICt` <- function (x, ..., value) { + if (!as.logical(length(value))) + return(x) + stopifnot(class(value) == class(x) & attr(x, "cal") == attr(value, "cal")) + cl <- oldClass(x) + x <- NextMethod("[<-") + x <- copy.atts.PCICt(value, x) + class(x) <- cl + x +} + +#'PCICt +#' +#'Functions from the PCICt package. These functions convert between PCICt +#'objects and other types of data. +#'@name as.PCICt +#'@param x The input data. +#' +#'@param cal The calendar type. +#' +#'@param ... Any additional arguments passed on. +#' +#'@aliases as.PCICt as.PCICt.default as.PCICt.POSIXlt as.PCICt.POSIXct +#' as.PCICt.numeric .PCICt as.POSIXct.PCICt as.POSIXlt.PCICt as.character.PCICt +#' +.PCICt -.PCICt Ops.PCICt [.PCICt [<-.PCICt round.PCICt +#' +#'@return For as.PCICt and .PCICt, a PCICt object with the given calendar type. +#' For as.POSIXct.PCICt and as.POSIXlt.PCICt, a POSIXct or POSIXlt +#' object, respectively. +#' +#'@export +#' +#'@useDynLib ClimProjDiags + +as.PCICt <- function(x, cal, ...) { + if(missing(cal)) stop("Can't create a PCICt with no calendar type") + UseMethod("as.PCICt") +} + +#'@noRd +as.character.PCICt <- function(x, ...) { + format.PCICt(x, ...) +} + +#'@noRd +unique.PCICt <- function(x, incomparables = FALSE, fromLast = FALSE, ...) { + if (!inherits(x, "PCICt")) + stop("wrong class") + z <- unique(unclass(x), incomparables, fromLast, ...) + return(copy.atts.PCICt(x, z)) +} + +#'@noRd +summary.PCICt <- function (object, digits = 15, ...) { + x <- summary.default(unclass(object), digits = digits, ...) + if (m <- match("NA's", names(x), 0)) { + NAs <- as.integer(x[m]) + x <- x[-m] + attr(x, "NAs") <- NAs + } + x <- copy.atts.PCICt(object, x) + class(x) <- c("summaryDefault", "table", oldClass(object)) + x +} + +#'@noRd +format.PCICt <- function(x, format="", tz="", usetz=FALSE, ...) { + if (!inherits(x, "PCICt")) + stop("wrong class") + + if(!is.null(attr(x, "dpy")) && attr(x, "dpy") == 360) { + structure(format.POSIXlt.360(as.POSIXlt(x, tz), format, + ...), names = names(x)) + } else { + structure(format.POSIXlt(as.POSIXlt(x, tz), format, usetz, + ...), names = names(x)) + } +} + +#'@noRd +print.PCICt <- function (x, ...) { + max.print <- getOption("max.print", 9999L) + if (max.print < length(x)) { + print(as.character(x[1:max.print]), ...) + cat(" [ reached getOption(\"max.print\") -- omitted", + length(x) - max.print, "entries ]\n") + } + else print(as.character(x), ...) + invisible(x) +} + +#'@noRd +strptime.360 <- function(x, format) { + .Call("do_strptime_360", x, format, + PACKAGE = "ClimProjDiags") +} + +#'@noRd +format.POSIXlt.360 <- function(x, format="", ...) { + if (!inherits(x, "POSIXlt")) + stop("wrong class") + if (format == "") { + times <- unlist(unclass(x)[1L:3L]) + secs <- x$sec + secs <- secs[!is.na(secs)] + np <- getOption("digits.secs") + if (is.null(np)) + np <- 0L + else np <- min(6L, np) + if (np >= 1L) + for (i in seq_len(np) - 1L) + if (all(abs(secs - round(secs, i)) < 1e-06)) { + np <- i + break + } + format <- if (all(times[!is.na(times)] == 0)) + "%Y-%m-%d" + else if (np == 0L) + "%Y-%m-%d %H:%M:%S" + else paste("%Y-%m-%d %H:%M:%OS", np, sep="") + } + y <- .Call("do_formatPOSIXlt_360", x, format, + PACKAGE = "ClimProjDiags") + names(y) <- names(x$year) + format(y, ...) +} + +#'@noRd +as.POSIXct.POSIXlt.360 <- function(x, ...) { + .Call("do_asPOSIXct_360", x) +} + +#'@noRd +as.POSIXlt.POSIXct.360 <- function(x, ...) { + .Call("do_asPOSIXlt_360", x) +} + +#'@noRd +as.PCICt.default <- function(x, cal, format, ...) { + tz <- "GMT" + cal.cleaned <- clean.cal(cal) + if (inherits(x, "PCICt")) + return(x) + if (is.character(x) || is.factor(x)) { + x <- as.character(x) + if(cal.cleaned == "360") { + if (!missing(format)) { + res <- strptime.360(x, format) + return(as.PCICt(res, cal, ...)) + } + x <- unclass(x) + xx <- x[!is.na(x)] + if (!length(xx)) + res <- strptime.360(x, "%Y/%m/%d") + else if (all(!is.na(strptime.360(xx, f <- "%Y-%m-%d %H:%M:%OS"))) || + all(!is.na(strptime.360(xx, f <- "%Y/%m/%d %H:%M:%OS"))) || + all(!is.na(strptime.360(xx, f <- "%Y-%m-%d %H:%M"))) || + all(!is.na(strptime.360(xx, f <- "%Y/%m/%d %H:%M"))) || + all(!is.na(strptime.360(xx, f <- "%Y-%m-%d"))) || + all(!is.na(strptime.360(xx, f <- "%Y/%m/%d")))) + res <- strptime.360(x, f) + if(missing(res)) stop("character string is not in a standard unambiguous format") + return(as.PCICt(res, cal, ...)) + } else { + return(as.PCICt(as.POSIXlt(x, tz, format, ...), cal, ...)) + } + } + if (is.logical(x) && all(is.na(x))) + return(.PCICt(as.numeric(x), cal)) + stop(gettextf("do not know how to convert '%s' to class \"PCICt\"", deparse(substitute(x)))) +} + +#'@noRd +as.PCICt.numeric <- function(x, cal, origin, ...) { + if (missing(origin)) + stop("'origin' must be supplied") + + if(inherits(origin, "PCICt") && attr(origin, "cal") == cal) + return(origin + x) + else + return(as.PCICt(origin, cal) + x) +} + +#'@noRd +as.PCICt.POSIXlt <- function(x, cal, ...) { + proleptic.correction <- 0 + seconds.per.day <- 86400 + tz <- "GMT" + cal.cleaned <- clean.cal(cal) + year.length <- dpy.for.cal(cal.cleaned) + + if(is.null(year.length)) { + d <- as.POSIXct(x, tz="GMT") + class(d) <- NULL + return(.PCICt(d, "proleptic_gregorian")) + } else { + months <- PCICt.get.months(cal.cleaned) + months.off <- cumsum(c(0, months[1:(length(months) - 1)])) + seconds.per.hour <- 3600 + return(.PCICt((x$year + origin.year.POSIXlt - origin.year + floor(x$mon / 12)) * year.length * seconds.per.day + + months.off[(x$mon %% 12) + 1] * seconds.per.day + (x$mday - 1) * seconds.per.day + x$hour * seconds.per.hour + x$min * 60 + x$sec, cal=cal)) + } +} + +#'@noRd +as.PCICt.POSIXct <- function(x, cal, ...) { + cal.cleaned <- clean.cal(cal) + if(cal.cleaned == "360") { + as.PCICt.POSIXlt(as.POSIXlt.POSIXct.360(x), cal, ...) + } else { + as.PCICt.POSIXlt(as.POSIXlt(x), cal, ...) + } +} + +## FIXME: Better NA handling +#'@noRd +as.POSIXlt.PCICt <- function(x, tz="", ...) { + seconds.per.day <- 86400 + seconds.per.hour <- 3600 + + tzone <- attr(x, "tzone") + if (length(tz) == 0 && !is.null(tzone)) + tz <- tzone[1L] + + if(is.null(attr(x, "months"))) { + class(x) <- c("POSIXct", "POSIXt") + return(as.POSIXlt(x)) + } else { + months <- attr(x, "months") + months.off <- cumsum(c(0, months[1:(length(months) - 1)])) + months.idx <- unlist(lapply(1:12, function(x) { rep(x, months[x]) } )) + + days.per.year <- attr(x, "dpy") + remainder <- as.numeric(x) %% (days.per.year * seconds.per.day) + remainder[remainder < 0] <- days.per.year * seconds.per.day - remainder[remainder < 0] + + year <- floor(as.numeric(x) / (days.per.year * seconds.per.day)) + origin.year + yday <- floor(remainder / seconds.per.day) + 1 + month <- months.idx[yday] + day <- yday - months.off[month] + + ## Need to compute wday + wday <- (as.numeric(x) / 86400) %% 7 + hms.remainder <- remainder %% seconds.per.day + hour <- floor(hms.remainder / seconds.per.hour) + minute <- floor((hms.remainder %% seconds.per.hour) / 60) + second <- hms.remainder %% 60 + return(.POSIXlt(list(sec=second, min=minute, hour=hour, mday=day, mon=month - 1, year=year - origin.year.POSIXlt, wday=wday, yday=yday - 1, isdst=0), tz)) + } +} + +#'@noRd +as.POSIXct.PCICt <- function(x, tz="", ...) { + + if(attr(x, "cal") == "360") { + warning("360-day PCICt objects can't be properly represented by a POSIXct object") + } + return(as.POSIXct(as.POSIXlt(x, tz))) +} + +#'@noRd +cut.PCICt <- function (x, breaks, labels = NULL, start.on.monday = TRUE, right = FALSE, ...) { + if(!inherits(x, "PCICt")) stop("'x' must be a PCICt object") + cal <- attr(x, "cal") + + if (inherits(breaks, "PCICt") || (is.numeric(breaks) && length(breaks) == 1L)) { + ## Dates are already PCICt or specified number of breaks; don't need to do anything + } else if(is.character(breaks) && length(breaks) == 1L) { + ## Breaks are characters; need to do something. + by2 <- strsplit(breaks, " ", fixed=TRUE)[[1L]] + if(length(by2) > 2L || length(by2) < 1L) + stop("invalid specification of 'breaks'") + valid <- pmatch(by2[length(by2)], + c("secs", "mins", "hours", "days", "weeks", + "months", "years", "DSTdays", "quarters")) + if(is.na(valid)) stop("invalid specification of 'breaks'") + start <- as.POSIXlt(min(x, na.rm=TRUE)) + incr <- 1 + if(valid > 1L) { start$sec <- 0L; incr <- 60 } + if(valid > 2L) { start$min <- 0L; incr <- 3600 } + ## start of day need not be on the same DST, PR#14208 + if(valid > 3L) { start$hour <- 0L; start$isdst <- -1L; incr <- 86400 } + if(valid == 5L) { # weeks + start$mday <- start$mday - start$wday + if(start.on.monday) + start$mday <- start$mday + ifelse(start$wday > 0L, 1L, -6L) + incr <- 7*86400 + } + if(valid == 8L) incr <- 25*3600 # DSTdays + if(valid == 6L) { # months + start$mday <- 1L + maxx <- max(x, na.rm = TRUE) + step <- ifelse(length(by2) == 2L, as.integer(by2[1L]), 1L) + end <- as.POSIXlt(maxx + (ifelse(cal == "360", 30, 31) * step * 86400)) + end$mday <- 1L + end$isdst <- -1L + breaks <- seq(as.PCICt(start, cal), as.PCICt(end, cal), breaks) + } else if(valid == 7L) { # years + start$mon <- 0L + start$mday <- 1L + maxx <- max(x, na.rm = TRUE) + step <- ifelse(length(by2) == 2L, as.integer(by2[1L]), 1L) + end <- as.POSIXlt(maxx + (ceiling(get.avg.dpy(x)) * step* 86400)) + end$mon <- 0L + end$mday <- 1L + end$isdst <- -1L + breaks <- seq(as.PCICt(start, cal), as.PCICt(end, cal), breaks) + } else if(valid == 9L) { # quarters + qtr <- rep(c(0L, 3L, 6L, 9L), each = 3L) + start$mon <- qtr[start$mon + 1L] + start$mday <- 1L + maxx <- max(x, na.rm = TRUE) + step <- ifelse(length(by2) == 2L, as.integer(by2[1L]), 1L) + end <- as.POSIXlt(maxx + (floor(get.avg.dpy(x) / 4) * step * 86400)) + end$mon <- qtr[end$mon + 1L] + end$mday <- 1L + end$isdst <- -1L + breaks <- seq(as.PCICt(start, cal), as.PCICt(end, cal), paste(step * 3, "months")) + ## 90-93 days ahead could give an empty level, so + lb <- length(breaks) + if(maxx < breaks[lb-1]) breaks <- breaks[-lb] + } else { # weeks or shorter + if (length(by2) == 2L) incr <- incr * as.integer(by2[1L]) + maxx <- max(x, na.rm = TRUE) + breaks <- seq(as.PCICt(start, cal), maxx + incr, breaks) + breaks <- breaks[seq_len(1+max(which(breaks <= maxx)))] + } + } else stop("invalid specification of 'breaks'") + res <- cut(unclass(x), unclass(breaks), labels = labels, + right = right, ...) + if(is.null(labels)) { + levels(res) <- + as.character(if (is.numeric(breaks)) x[!duplicated(res)] + else breaks[-length(breaks)]) + } + res +} + +#'@noRd +diff.PCICt <- function (x, lag = 1L, differences = 1L, ...) { + class(x) <- c("POSIXct", "POSIXt") + diff(x, lag, differences, ...) +} + +#'@noRd +is.numeric.PCICt <- function(x) FALSE + +#'@noRd +julian.PCICt <- function (x, origin=NULL, ...) { + if(is.null(origin)) + origin <- "1970-01-01" + else + stopifnot(attr(x, "cal") == attr(origin, "cal")) + + origin <- as.PCICt(origin, cal=attr(x, "cal")) + class(x) <- class(origin) <- c("POSIXct", "POSIXt") + if (length(origin) != 1L) + stop("'origin' must be of length one") + + res <- difftime(x, origin, units = "days") + structure(res, origin = origin) +} + +get.sec.incr <- function(x, secs, incr=1, mul=1.1) { + if(length(secs) == 0 || mul * (incr * secs[1]) > x) + incr + else + get.sec.incr(x, secs[-1], incr * secs[1], mul) +} + +#'@importFrom graphics axis +#'@noRd +Axis.PCICt <- function(x = NULL, at = NULL, ..., side, labels = TRUE) { + axis.PCICt(side = side, x = x, at = at, labels = labels, ...) +} + +get.avg.dpy <- function(x) { + ifelse(is.null(attr(x, "dpy")), 365.25, attr(x, "dpy")) +} + +#'@importFrom graphics axis par +#'@noRd +axis.PCICt <- function(side, x, at, format, labels = TRUE, ...) { + mat <- missing(at) || is.null(at) + mft <- missing(format) || is.null(format) + if (!mat) + x <- at + + range <- par("usr")[if (side%%2) 1L:2L else 3L:4L] + + d <- range[2L] - range[1L] + z <- c(as.PCICt(range, cal=attr(x, "cal"), origin="1970-01-01"), x[is.finite(x)]) + + sc <- get.sec.incr(d, c(60, 60, 24, 7)) + if(mft && !is.na(sc)) + format <- switch(as.character(sc), "1"="%S", "60"="%M:%S", "3600"="%H:%M", "86400"="%a %H:%M", "604800"="%a") + + if (d < 60 * 60 * 24 * 50) { + zz <- pretty(unclass(z)/sc) + z <- .PCICt(zz * sc, cal=attr(x, "cal")) + if (!is.na(sc) && sc == 60 * 60 * 24) + z <- round(z, "days") + if (mft) + format <- "%b %d" + } else if (d < 1.1 * 60 * 60 * 24 * get.avg.dpy(x)) { + zz <- as.POSIXlt(z) + zz$mday <- zz$wday <- zz$yday <- 1 + zz$isdst <- -1 + zz$hour <- zz$min <- zz$sec <- 0 + zz$mon <- pretty(zz$mon) + m <- length(zz$mon) + M <- 2 * m + m <- rep.int(zz$year[1L], m) + zz$year <- c(m, m + 1) + zz <- lapply(zz, function(x) rep(x, length.out = M)) + z <- as.PCICt(zz, attr(x, "cal")) + if (mft) + format <- "%b" + } else { + zz <- as.POSIXlt(z) + zz$mday <- zz$wday <- zz$yday <- 1 + zz$isdst <- -1 + zz$mon <- zz$hour <- zz$min <- zz$sec <- 0 + zz$year <- pretty(zz$year) + M <- length(zz$year) + zz <- lapply(zz, function(x) rep(x, length.out = M)) + z <- as.PCICt(.POSIXlt(zz), attr(x, "cal")) + if (mft) + format <- "%Y" + } + if (!mat) + z <- x[is.finite(x)] + + keep <- z >= range[1L] & z <= range[2L] + z <- z[keep] + if (!is.logical(labels)) + labels <- labels[keep] + else if (identical(labels, TRUE)) + labels <- format(z, format = format) + else if (identical(labels, FALSE)) + labels <- rep("", length(z)) + + axis(side, at = unclass(z), labels = labels, ...) +} + +#'@noRd +pretty.PCICt <- function(x, n = 5, min.n = n %/% 2, sep = " ", ...) { + zz <- range(x, na.rm = TRUE) + xspan <- as.numeric(diff(zz), units = "secs") + if (diff(as.numeric(zz)) == 0) # one value only + zz <- zz + c(0,60) + ## specify the set of pretty timesteps + MIN <- 60 + HOUR <- MIN * 60 + DAY <- HOUR * 24 + YEAR <- DAY * get.avg.dpy(x) + MONTH <- YEAR / 12 + steps <- + list("1 sec" = list(1, format = "%S", start = "mins"), + "2 secs" = list(2), + "5 secs" = list(5), + "10 secs" = list(10), + "15 secs" = list(15), + "30 secs" = list(30, format = "%H:%M:%S"), + "1 min" = list(1*MIN, format = "%H:%M"), + "2 mins" = list(2*MIN, start = "hours"), + "5 mins" = list(5*MIN), + "10 mins" = list(10*MIN), + "15 mins" = list(15*MIN), + "30 mins" = list(30*MIN), + ## "1 hour" = list(1*HOUR), + "1 hour" = list(1*HOUR, format = if (xspan <= DAY) "%H:%M" else paste("%b %d", "%H:%M", sep = sep)), + "3 hours" = list(3*HOUR, start = "days"), + "6 hours" = list(6*HOUR, format = paste("%b %d", "%H:%M", sep = sep)), + "12 hours" = list(12*HOUR), + "1 DSTday" = list(1*DAY, format = paste("%b", "%d", sep = sep)), + "2 DSTdays" = list(2*DAY), + "1 week" = list(7*DAY, start = "weeks"), + "halfmonth" = list(MONTH/2, start = "months"), + ## "1 month" = list(1*MONTH, format = "%b"), + "1 month" = list(1*MONTH, format = if (xspan < YEAR) "%b" else paste("%b", "%Y", sep = sep)), + "3 months" = list(3*MONTH, start = "years"), + "6 months" = list(6*MONTH, format = "%Y-%m"), + "1 year" = list(1*YEAR, format = "%Y"), + "2 years" = list(2*YEAR, start = "decades"), + "5 years" = list(5*YEAR), + "10 years" = list(10*YEAR), + "20 years" = list(20*YEAR, start = "centuries"), + "50 years" = list(50*YEAR), + "100 years" = list(100*YEAR), + "200 years" = list(200*YEAR), + "500 years" = list(500*YEAR), + "1000 years" = list(1000*YEAR)) + ## carry forward 'format' and 'start' to following steps + for (i in seq_along(steps)) { + if (is.null(steps[[i]]$format)) + steps[[i]]$format <- steps[[i-1]]$format + if (is.null(steps[[i]]$start)) + steps[[i]]$start <- steps[[i-1]]$start + steps[[i]]$spec <- names(steps)[i] + } + ## crudely work out number of steps in the given interval + nsteps <- sapply(steps, function(s) { + xspan / s[[1]] + }) + init.i <- which.min(abs(nsteps - n)) + ## calculate actual number of ticks in the given interval + calcSteps <- function(s) { + startTime <- trunc(min(zz), units = s$start) + if (identical(s$spec, "halfmonth")) { + at <- seq(startTime, max(zz), by = "months") + at2 <- as.POSIXlt(at) + at2$mday <- 15L + at3 <- sort(c(at, as.PCICt(at2))) + at <- copy.atts.PCICt(at, at3) + } else { + at <- seq(startTime, max(zz), by = s$spec) + } + at <- at[(min(zz) <= at) & (at <= max(zz))] + at + } + init.at <- calcSteps(steps[[init.i]]) + init.n <- length(init.at) - 1L + ## bump it up if below acceptable threshold + while (init.n < min.n) { + init.i <- init.i - 1L + if (init.i == 0) stop("range too small for min.n") + init.at <- calcSteps(steps[[init.i]]) + init.n <- length(init.at) - 1L + } + makeOutput <- function(at, s) { + flabels <- format(at, s$format) + ans <- as.PCICt(at, cal=attr(x, "cal")) + attr(ans, "labels") <- flabels + ans + } + if (init.n == n) ## perfect + return(makeOutput(init.at, steps[[init.i]])) + if (init.n > n) { + ## too many ticks + new.i <- init.i + 1L + new.i <- min(new.i, length(steps)) + } else { + ## too few ticks + new.i <- init.i - 1L + new.i <- max(new.i, 1L) + } + new.at <- calcSteps(steps[[new.i]]) + new.n <- length(new.at) - 1L + ## work out whether new.at or init.at is better + if (new.n < min.n) + new.n <- -Inf + if (abs(new.n - n) < abs(init.n - n)) + makeOutput(new.at, steps[[new.i]]) + else + makeOutput(init.at, steps[[init.i]]) +} diff --git a/R/SeasonSelect.R b/R/SeasonSelect.R index 6ee8fbbc72c237c95b4bcb4f50ca35460ccaee97..6eb5192b5d340f7b952f5a094699edcfe9d122fa 100644 --- a/R/SeasonSelect.R +++ b/R/SeasonSelect.R @@ -25,7 +25,6 @@ #' corresponding to the selected season.} #'} #' -#'@import PCICt #'@examples #'## Example with synthetic data: #'data <- 1:(2 * 3 * (366 + 365) * 2) diff --git a/R/Threshold.R b/R/Threshold.R index 7444e1ffacc2b33602b7edc38be419f273cf693f..c686d5cb872bcfd1c01fd442cb36689cd067e183 100644 --- a/R/Threshold.R +++ b/R/Threshold.R @@ -18,7 +18,6 @@ #''time' dimension, and a new 'jdays' dimension. #' #'@import multiApply -#'@import PCICt #'@importFrom stats quantile #'@examples #'##Example synthetic data: diff --git a/R/WaveDuration.R b/R/WaveDuration.R index 5206c322747b01cdaceb18723ea979180cae39d8..a6d6a0956d4bf25971528acf556589aabffff0b0 100644 --- a/R/WaveDuration.R +++ b/R/WaveDuration.R @@ -34,7 +34,6 @@ #'} #' #'@import multiApply -#'@import PCICt #'@examples #'##Example synthetic data: #'data <- 1:(2 * 3 * 31 * 5) diff --git a/README.md b/README.md index 3831630393670a8c39cd20766431db8f3ddfe68b..82a48f0940fcb6b33512711637bf0232999d359f 100644 --- a/README.md +++ b/README.md @@ -27,5 +27,5 @@ The main functionalities are presented in four different vignettes with step by ### How to contribute? -Information on questions, contributions and bug reports can be found in [**CONTRIBUTING.md**](CONTRIBUTING.md). +Information on questions, contributions and bug reports can be found in [**CONTRIBUTING.md**](https://earth.bsc.es/gitlab/es/ClimProjDiags/blob/master/CONTRIBUTING.md). diff --git a/man/ArrayToList.Rd b/man/ArrayToList.Rd index 43d3278653cac0aa7a01c773d04ed9dd0c627f57..878550b3b1740f61c9a830d9e94bf20bda014eea 100644 --- a/man/ArrayToList.Rd +++ b/man/ArrayToList.Rd @@ -24,7 +24,8 @@ A list of arrays of the length of the dimension set in parameter 'dim'. } \description{ This function splits an array into a list as required by -PlotLayout function from package "s2dv" when parameter 'special_args' is used. +PlotLayout function from package "s2dv" when parameter 'special_args' is used. +See: N. Manubens et al. (2018) <. The function ArrayToList allows to add names to the elements of the list in two different levels, the 'list' or the 'sublist'. } @@ -42,6 +43,3 @@ class(datalist[[1]]) class(datalist[[1]][[1]]) str(datalist) } -\seealso{ -\link[s2dv]{PlotLayout} -} diff --git a/man/as.PCICt.Rd b/man/as.PCICt.Rd new file mode 100644 index 0000000000000000000000000000000000000000..49343ce5353957b9691708803b015facb6c65942 --- /dev/null +++ b/man/as.PCICt.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PCICtFunctions.R +\name{as.PCICt} +\alias{as.PCICt} +\alias{as.PCICt.default} +\alias{as.PCICt.POSIXlt} +\alias{as.PCICt.POSIXct} +\alias{as.PCICt.numeric} +\alias{.PCICt} +\alias{as.POSIXct.PCICt} +\alias{as.POSIXlt.PCICt} +\alias{as.character.PCICt} +\alias{+.PCICt} +\alias{-.PCICt} +\alias{Ops.PCICt} +\alias{[.PCICt} +\alias{[<-.PCICt} +\alias{round.PCICt} +\title{PCICt} +\usage{ +as.PCICt(x, cal, ...) +} +\arguments{ +\item{x}{The input data.} + +\item{cal}{The calendar type.} + +\item{...}{Any additional arguments passed on.} +} +\value{ +For as.PCICt and .PCICt, a PCICt object with the given calendar type. + For as.POSIXct.PCICt and as.POSIXlt.PCICt, a POSIXct or POSIXlt + object, respectively. +} +\description{ +Functions from the PCICt package. These functions convert between PCICt +objects and other types of data. +} diff --git a/src/ClimProjDiags.so b/src/ClimProjDiags.so new file mode 100755 index 0000000000000000000000000000000000000000..9f149cc1236f85ad2ba3eb01616543f5f0ddc66a Binary files /dev/null and b/src/ClimProjDiags.so differ diff --git a/src/PCICt_init.c b/src/PCICt_init.c new file mode 100644 index 0000000000000000000000000000000000000000..b0c8446f9375032c84ccc0bccb633f735be9ad2a --- /dev/null +++ b/src/PCICt_init.c @@ -0,0 +1,24 @@ +#include +#include +#include // for NULL +#include + +/* .Call calls */ +extern SEXP do_asPOSIXct_360(SEXP); +extern SEXP do_asPOSIXlt_360(SEXP); +extern SEXP do_formatPOSIXlt_360(SEXP, SEXP); +extern SEXP do_strptime_360(SEXP, SEXP); + +static const R_CallMethodDef CallEntries[] = { + {"do_asPOSIXct_360", (DL_FUNC) &do_asPOSIXct_360, 1}, + {"do_asPOSIXlt_360", (DL_FUNC) &do_asPOSIXlt_360, 1}, + {"do_formatPOSIXlt_360", (DL_FUNC) &do_formatPOSIXlt_360, 2}, + {"do_strptime_360", (DL_FUNC) &do_strptime_360, 2}, + {NULL, NULL, 0} +}; + +void R_init_PCICt(DllInfo *dll) +{ + R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); + R_useDynamicSymbols(dll, FALSE); +} diff --git a/src/PCICt_init.o b/src/PCICt_init.o new file mode 100644 index 0000000000000000000000000000000000000000..9caa9d1429e9d42d0c8810d7b7f38daf68d6641b Binary files /dev/null and b/src/PCICt_init.o differ diff --git a/src/datetime_360.c b/src/datetime_360.c new file mode 100644 index 0000000000000000000000000000000000000000..1def8543a4d3643a13723a910d2ee2c2581f2829 --- /dev/null +++ b/src/datetime_360.c @@ -0,0 +1,963 @@ +/* + * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 2000-2012 The R Core Team. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, a copy is available at + * http://www.r-project.org/Licenses/ + * + * + * Interfaces to POSIX date and time functions. + */ + +/* NOTE: + This file contains modifications of the POSIX functions originally in R's + datetime.c to (only) work with 360-day calendars in GMT. + */ + +/* + These use POSIX functions that are not available on all platforms, + and where they are they may be partially or incorrectly + implemented. A number of lightweight alternatives are supplied, + but generally timezone support is only available if the OS + supplies it (or as on Windows, we replace it). However, as these + are now also mandated by C99, they are almost universally + available, albeit with more room for implementation variations. + + A particular problem is the setting of the timezone TZ on + Unix/Linux. POSIX appears to require it, yet older Linux systems + do not set it and do not give the correct results/crash strftime + if it is not set (or even if it is: see the workaround below). We + use unsetenv() to work around this: that is a BSD (and POSIX 2001) + construct but seems to be available on the affected platforms. + + Notes on various time functions: + =============================== + + The current (2008) POSIX recommendation to find the calendar time + is to call clock_gettime(), defined in . This may also be + used to find time since some unspecified starting point + (e.g. machine reboot), but is not currently so used in R. It + returns in second and nanoseconds, although not necessarily to + more than clock-tick accuracy. + + C11 adds 'struct timespec' to . And timespec_get() can get + the current time or interval after a base time. + + The previous POSIX recommendation was gettimeofday(), defined in + . This returns in seconds and microseconds (with + unspecified granularity). + + Many systems (including AIX, FreeBSD, Linux, Solaris) have + clock_gettime(). Mac OS X and Cygwin have gettimeofday(). + + Function time() is C99 and defined in . C99 does not + mandate the units, but POSIX does (as the number of seconds since + the epoch: although not mandated, time_t seems always to be an + integer type). + + Function clock() is C99 and defined in . It measures CPU + time at CLOCKS_PER_SEC: there is a small danger of integer + overflow. + + Function times() is POSIX and defined in . It + returns the elapsed time in clock ticks, plus CPU times in a + struct tms* argument (also in clock ticks). + + More precise information on CPU times may be available from the + POSIX function getrusage() defined in . This + returns the same time structure as gettimeofday() and on some + systems offers millisecond resolution. + It is available on Cygwin, FreeBSD, Mac OS X, Linux and Solaris. + + currentTime() (in this file) uses + clock_gettime(): AIX, FreeBSD, Linux, Solaris + gettimeofday(): Mac OS X, Windows, Cygwin + time() (as ultimate fallback, AFAIK unused). + + proc.time() uses currentTime() for elapsed time, + and getrusage, then times for CPU times on a Unix-alike, + GetProcessTimes on Windows. + + devPS.c uses time() and localtime() for timestamps. + + do_date (platform.c) uses ctime. + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +/* needed on Windows to avoid redefinition of tzname as _tzname */ +#define _NO_OLDNAMES +#include +#undef _NO_OLDNAMES + +#include + +#ifdef Win32 +#define gmtime R_gmtime +#define localtime R_localtime +#define mktime R_mktime +extern struct tm* gmtime (const time_t*); +extern struct tm* localtime (const time_t*); +extern time_t mktime (struct tm*); +#endif + +#include /* for setenv or putenv */ +#include +#include +#include + +/* The glibc in RH8.0 was broken and assumed that dates before + 1970-01-01 do not exist. So does Windows, but its code was replaced + in R 2.7.0. As from 1.6.2, test the actual mktime code and cache + the result on glibc >= 2.2. (It seems this started between 2.2.5 + and 2.3, and RH8.0 had an unreleased version in that gap.) + + Sometime in late 2004 this was reverted in glibc. +*/ + +static Rboolean have_broken_mktime(void) +{ +#if defined(_AIX) + return TRUE; +#elif defined(__GLIBC__) && defined(__GLIBC_MINOR__) && __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 2 + static int test_result = -1; + + if (test_result == -1) { + struct tm t; + time_t res; + t.tm_sec = t.tm_min = t.tm_hour = 0; + t.tm_mday = t.tm_mon = 1; + t.tm_year = 68; + t.tm_isdst = -1; + res = mktime(&t); + test_result = (res == (time_t)-1); + } + return test_result > 0; +#else + return FALSE; +#endif + + +} + +/* Substitute based on glibc code. */ +#include "strptime_360.h" + +static const int days_in_month[12] = +{30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30}; + +#define days_in_year 360 + +#ifndef HAVE_POSIX_LEAPSECONDS +/* There have been 24 leapseconds, the last being on 2008-12-31. + */ +static int n_leapseconds = 24; +static const time_t leapseconds[] = +{ 78796800, 94694400,126230400,157766400,189302400,220924800,252460800, + 283996800,315532800,362793600,394329600,425865600,489024000,567993600, + 631152000,662688000,709948800,741484800,773020800,820454400,867715200, + 915148800,1136073600,1230768000}; +#endif + +/* + Adjust a struct tm to be a valid date-time. + Return 0 if valid, -1 if invalid and uncorrectable, or a positive + integer approximating the number of corrections needed. + */ +static int validate_tm (struct tm *tm) +{ + int tmp, res = 0; + + if (tm->tm_sec < 0 || tm->tm_sec > 60) { /* 61 POSIX, 60 draft ISO C */ + res++; + tmp = tm->tm_sec/60; + tm->tm_sec -= 60 * tmp; tm->tm_min += tmp; + if(tm->tm_sec < 0) {tm->tm_sec += 60; tm->tm_min--;} + } + + if (tm->tm_min < 0 || tm->tm_min > 59) { + res++; + tmp = tm->tm_min/60; + tm->tm_min -= 60 * tmp; tm->tm_hour += tmp; + if(tm->tm_min < 0) {tm->tm_min += 60; tm->tm_hour--;} + } + + if(tm->tm_hour == 24 && tm->tm_min == 0 && tm->tm_sec == 0) { + tm->tm_hour = 0; tm->tm_mday++; + if(tm->tm_mon >= 0 && tm->tm_mon <= 11) { + if(tm->tm_mday > days_in_month[tm->tm_mon]) { + tm->tm_mon++; tm->tm_mday = 1; + if(tm->tm_mon == 12) { + tm->tm_year++; tm->tm_mon = 0; + } + } + } + } + if (tm->tm_hour < 0 || tm->tm_hour > 23) { + res++; + tmp = tm->tm_hour/24; + tm->tm_hour -= 24 * tmp; tm->tm_mday += tmp; + if(tm->tm_hour < 0) {tm->tm_hour += 24; tm->tm_mday--;} + } + + /* defer fixing mday until we know the year */ + if (tm->tm_mon < 0 || tm->tm_mon > 11) { + res++; + tmp = tm->tm_mon/12; + tm->tm_mon -= 12 * tmp; tm->tm_year += tmp; + if(tm->tm_mon < 0) {tm->tm_mon += 12; tm->tm_year--;} + } + + /* A limit on the loops of about 3000x round */ + if(tm->tm_mday < -1000000 || tm->tm_mday > 1000000) return -1; + + if(abs(tm->tm_mday) > 366) { + res++; + /* first spin back until January */ + while(tm->tm_mon > 0) { + --tm->tm_mon; + tm->tm_mday += days_in_month[tm->tm_mon]; + } + /* then spin on/back by years */ + while(tm->tm_mday < 1) { + --tm->tm_year; + tm->tm_mday += days_in_year; + } + while(tm->tm_mday > days_in_year) { + tm->tm_mday -= days_in_year; tm->tm_year++; + } + } + + while(tm->tm_mday < 1) { + res++; + if(--tm->tm_mon < 0) {tm->tm_mon += 12; tm->tm_year--;} + tm->tm_mday += days_in_month[tm->tm_mon]; + } + + while(tm->tm_mday > (tmp = days_in_month[tm->tm_mon])) { + res++; + if(++tm->tm_mon > 11) {tm->tm_mon -= 12; tm->tm_year++;} + tm->tm_mday -= tmp; + } + return res; +} + + +/* Substitute for mktime -- no checking, always in GMT */ +static double mktime00 (struct tm *tm) +{ + int day = 0; + int i, year, year0; + double excess = 0.0; + + day = tm->tm_mday - 1; + year0 = 1900 + tm->tm_year; + /* safety check for unbounded loops */ + if (year0 > 3000) { + excess = (int)(year0/2000) - 1; + year0 -= (int)(excess * 2000); + } else if (year0 < 0) { + excess = -1 - (int)(-year0/2000); + year0 -= (int)(excess * 2000); + } + + for(i = 0; i < tm->tm_mon; i++) day += days_in_month[i]; + tm->tm_yday = day; + + if (year0 > 1970) { + for (year = 1970; year < year0; year++) + day += days_in_year; + } else if (year0 < 1970) { + for (year = 1969; year >= year0; year--) + day -= days_in_year; + } + + /* weekday: Epoch day was a Thursday */ + if ((tm->tm_wday = (day + 4) % 7) < 0) tm->tm_wday += 7; + + return tm->tm_sec + (tm->tm_min * 60) + (tm->tm_hour * 3600) + + (day + excess * 730485) * 86400.0; +} + +static double guess_offset (struct tm *tm) +{ + double offset, offset1, offset2; + int i, wday, year, oldmonth, oldisdst, oldmday; + struct tm oldtm; + /* + Adjust as best we can for timezones: if isdst is unknown, use + the smaller offset at same day in Jan or July of a valid year. + We don't know the timezone rules, but if we choose a year with + July 1 on the same day of the week we will likely get guess + right (since they are usually on Sunday mornings not in Jan/Feb). + + Update for 2.7.0: no one had DST before 1916, so just use the offset + in 1902, if available. + */ + + memcpy(&oldtm, tm, sizeof(struct tm)); + if(!have_broken_mktime() && tm->tm_year < 2) { /* no DST */ + tm->tm_year = 2; + mktime(tm); + offset1 = (double) mktime(tm) - mktime00(tm); + memcpy(tm, &oldtm, sizeof(struct tm)); + tm->tm_isdst = 0; + return offset1; + } + oldmonth = tm->tm_mon; + oldmday = tm->tm_mday; + /* We know there was no DST prior to 1916 */ + oldisdst = (tm->tm_year < 16) ? 0 : tm->tm_isdst; + + /* so now look for a suitable year */ + tm->tm_mon = 6; + tm->tm_mday = 1; + tm->tm_isdst = -1; + mktime00(tm); /* to get wday valid */ + wday = tm->tm_wday; + if (oldtm.tm_year > 137) { /* in the unknown future */ + for(i = 130; i < 137; i++) { /* These cover all the possibilities */ + tm->tm_year = i; + mktime(tm); + if(tm->tm_wday == wday) break; + } + } else { /* a benighted OS with date before 1970 */ + /* We could not use 1970 because of the Windows bug with + 1970-01-01 east of GMT. */ + for(i = 71; i < 82; i++) { /* These cover all the possibilities */ + tm->tm_year = i; + mktime(tm); + if(tm->tm_wday == wday) break; + } + } + year = i; + + /* Now look up offset in January */ + tm->tm_mday = oldmday; + tm->tm_mon = 0; + tm->tm_year = year; + tm->tm_isdst = -1; + offset1 = (double) mktime(tm) - mktime00(tm); + /* and in July */ + tm->tm_year = year; + tm->tm_mon = 6; + tm->tm_isdst = -1; + offset2 = (double) mktime(tm) - mktime00(tm); + if(oldisdst > 0) { + offset = (offset1 > offset2) ? offset2 : offset1; + } else { + offset = (offset1 > offset2) ? offset1 : offset2; + } + /* now try to guess dst if unknown */ + tm->tm_mon = oldmonth; + tm->tm_isdst = -1; + if(oldisdst < 0) { + offset1 = (double) mktime(tm) - mktime00(tm); + oldisdst = (offset1 < offset) ? 1:0; + if(oldisdst) offset = offset1; + } + /* restore all as mktime might alter it */ + memcpy(tm, &oldtm, sizeof(struct tm)); + /* and then set isdst */ + tm->tm_isdst = oldisdst; + return offset; +} + +/* Interface to mktime or mktime00 */ +static double mktime0 (struct tm *tm, const int local) +{ + double res; + Rboolean OK; +#ifndef HAVE_POSIX_LEAPSECONDS + int i; +#endif + + if(validate_tm(tm) < 0) { +#ifdef EOVERFLOW + errno = EOVERFLOW; +#else + errno = 79; +#endif + return (double)(-1); + } + if(!local) return mktime00(tm); + + OK = tm->tm_year < 138 && tm->tm_year >= (have_broken_mktime() ? 70 : 02); + if(OK) { + res = (double) mktime(tm); + if (res == (double)-1) return res; +#ifndef HAVE_POSIX_LEAPSECONDS + for(i = 0; i < n_leapseconds; i++) + if(res > leapseconds[i]) res -= 1.0; +#endif + return res; +/* watch the side effect here: both calls alter their arg */ + } else return guess_offset(tm) + mktime00(tm); +} + +/* Interface for localtime or gmtime or internal substitute */ +static struct tm * localtime0(const double *tp, const int local, struct tm *ltm) +{ + double d = *tp; + int day; + int y, tmp, mon, left, diff, diff2; + struct tm *res= ltm; + time_t t; + + if(d < 2147483647.0 && d > (have_broken_mktime() ? 0. : -2147483647.0)) { + t = (time_t) d; + /* if d is negative and non-integer then t will be off by one day + since we really need floor(). But floor() is slow, so we just + fix t instead as needed. */ + if (d < 0.0 && (double) t != d) t--; +#ifndef HAVE_POSIX_LEAPSECONDS + for(y = 0; y < n_leapseconds; y++) if(t > leapseconds[y] + y - 1) t++; +#endif + return local ? localtime(&t) : gmtime(&t); + } + + day = (int) floor(d/86400.0); + left = (int) (d - day * 86400.0 + 0.5); + + /* hour, min, and sec */ + res->tm_hour = left / 3600; + left %= 3600; + res->tm_min = left / 60; + res->tm_sec = left % 60; + + /* weekday: 1970-01-01 was a Thursday */ + if ((res->tm_wday = ((4 + day) % 7)) < 0) res->tm_wday += 7; + + /* year & day within year */ + y = 1970; + if (day >= 0) + for ( ; day >= (tmp = days_in_year); day -= tmp, y++); + else + for ( ; day < 0; --y, day += days_in_year ); + + y = res->tm_year = y - 1900; + res->tm_yday = day; + + /* month within year */ + for (mon = 0; + day >= (tmp = days_in_month[mon]); + day -= tmp, mon++); + res->tm_mon = mon; + res->tm_mday = day + 1; + + if(local) { + int shift; + /* daylight saving time is unknown */ + res->tm_isdst = -1; + + /* Try to fix up timezone differences */ + diff = (int)(guess_offset(res)/60); + shift = res->tm_min + 60*res->tm_hour; + res->tm_min -= diff; + validate_tm(res); + res->tm_isdst = -1; + /* now this might be a different day */ + if(shift - diff < 0) res->tm_yday--; + if(shift - diff > 24) res->tm_yday++; + diff2 = (int)(guess_offset(res)/60); + if(diff2 != diff) { + res->tm_min += (diff - diff2); + validate_tm(res); + } + return res; + } else { + res->tm_isdst = 0; /* no dst in GMT */ + return res; + } +} + + +/* clock_gettime, timespec_get time are in , already included */ +#ifdef HAVE_SYS_TIME_H +/* gettimeoday, including on Windows */ +# include +#endif + +#ifdef HAVE_UNISTD_H +#include /* for getpid */ +#endif + +#ifdef Win32 +extern void tzset(void); +/* tzname is in the headers as an import on MinGW-w64 */ +#define tzname Rtzname +extern char *Rtzname[2]; +#elif defined(__CYGWIN__) +extern __declspec(dllimport) char *tzname[2]; +#else +extern char *tzname[2]; +#endif + +static const char ltnames [][6] = +{ "sec", "min", "hour", "mday", "mon", "year", "wday", "yday", "isdst" }; + + +static void makelt(struct tm *tm, SEXP ans, int i, int valid, double frac_secs) +{ + int j; + + if(valid) { + REAL(VECTOR_ELT(ans, 0))[i] = tm->tm_sec + frac_secs; + INTEGER(VECTOR_ELT(ans, 1))[i] = tm->tm_min; + INTEGER(VECTOR_ELT(ans, 2))[i] = tm->tm_hour; + INTEGER(VECTOR_ELT(ans, 3))[i] = tm->tm_mday; + INTEGER(VECTOR_ELT(ans, 4))[i] = tm->tm_mon; + INTEGER(VECTOR_ELT(ans, 5))[i] = tm->tm_year; + INTEGER(VECTOR_ELT(ans, 6))[i] = tm->tm_wday; + INTEGER(VECTOR_ELT(ans, 7))[i] = tm->tm_yday; + INTEGER(VECTOR_ELT(ans, 8))[i] = tm->tm_isdst; + } else { + REAL(VECTOR_ELT(ans, 0))[i] = NA_REAL; + for(j = 1; j < 8; j++) + INTEGER(VECTOR_ELT(ans, j))[i] = NA_INTEGER; + INTEGER(VECTOR_ELT(ans, 8))[i] = -1; + } +} + + +SEXP do_asPOSIXlt_360(SEXP data) +{ + SEXP x, ans, ansnames, klass, GMT; + int i, n, valid; + + PROTECT(x = coerceVector(data, REALSXP)); + + n = LENGTH(x); + PROTECT(ans = allocVector(VECSXP, 9)); + for(i = 0; i < 9; i++) + SET_VECTOR_ELT(ans, i, allocVector(i > 0 ? INTSXP : REALSXP, n)); + + PROTECT(ansnames = allocVector(STRSXP, 9)); + for(i = 0; i < 9; i++) + SET_STRING_ELT(ansnames, i, mkChar(ltnames[i])); + + for(i = 0; i < n; i++) { + struct tm dummy, *ptm = &dummy; + double d = REAL(x)[i]; + if(R_FINITE(d)) { + ptm = localtime0(&d, 0, &dummy); + /* in theory localtime/gmtime always return a valid + struct tm pointer, but Windows uses NULL for error + conditions (like negative times). */ + valid = (ptm != NULL); + } else valid = 0; + makelt(ptm, ans, i, valid, d - floor(d)); + } + setAttrib(ans, R_NamesSymbol, ansnames); + PROTECT(klass = allocVector(STRSXP, 2)); + SET_STRING_ELT(klass, 0, mkChar("POSIXlt")); + SET_STRING_ELT(klass, 1, mkChar("POSIXt")); + classgets(ans, klass); + GMT = PROTECT(mkString("GMT")); + setAttrib(ans, install("tzone"), GMT); + UNPROTECT(5); + + return ans; +} + +SEXP do_asPOSIXct_360(SEXP data) +{ + SEXP x, ans; + int i, n = 0, nlen[9]; + struct tm tm; + double tmp; + + PROTECT(x = duplicate(data)); /* coerced below */ + if(!isVectorList(x) || LENGTH(x) != 9) + error(_("invalid '%s' argument"), "x"); + + for(i = 0; i < 6; i++) + if((nlen[i] = LENGTH(VECTOR_ELT(x, i))) > n) n = nlen[i]; + if((nlen[8] = LENGTH(VECTOR_ELT(x, 8))) > n) n = nlen[8]; + if(n > 0) { + for(i = 0; i < 6; i++) + if(nlen[i] == 0) + error(_("zero length component in non-empty POSIXlt structure")); + if(nlen[8] == 0) + error(_("zero length component in non-empty POSIXlt structure")); + } + /* coerce fields to integer or real */ + SET_VECTOR_ELT(x, 0, coerceVector(VECTOR_ELT(x, 0), REALSXP)); + for(i = 0; i < 6; i++) + SET_VECTOR_ELT(x, i, coerceVector(VECTOR_ELT(x, i), + i > 0 ? INTSXP: REALSXP)); + SET_VECTOR_ELT(x, 8, coerceVector(VECTOR_ELT(x, 8), INTSXP)); + + PROTECT(ans = allocVector(REALSXP, n)); + for(i = 0; i < n; i++) { + double secs = REAL(VECTOR_ELT(x, 0))[i%nlen[0]], fsecs = floor(secs); + tm.tm_sec = (int) fsecs; + tm.tm_min = INTEGER(VECTOR_ELT(x, 1))[i%nlen[1]]; + tm.tm_hour = INTEGER(VECTOR_ELT(x, 2))[i%nlen[2]]; + tm.tm_mday = INTEGER(VECTOR_ELT(x, 3))[i%nlen[3]]; + tm.tm_mon = INTEGER(VECTOR_ELT(x, 4))[i%nlen[4]]; + tm.tm_year = INTEGER(VECTOR_ELT(x, 5))[i%nlen[5]]; + /* mktime ignores tm.tm_wday and tm.tm_yday */ + tm.tm_isdst = 0; + if(!R_FINITE(secs) || tm.tm_min == NA_INTEGER || + tm.tm_hour == NA_INTEGER || tm.tm_mday == NA_INTEGER || + tm.tm_mon == NA_INTEGER || tm.tm_year == NA_INTEGER) + REAL(ans)[i] = NA_REAL; + else { + errno = 0; + tmp = mktime0(&tm, 0); +#ifdef MKTIME_SETS_ERRNO + REAL(ans)[i] = errno ? NA_REAL : tmp + (secs - fsecs); +#else + REAL(ans)[i] = (tmp == (double)(-1)) ? + NA_REAL : tmp + (secs - fsecs); +#endif + } + } + + UNPROTECT(2); + return ans; +} + +SEXP do_formatPOSIXlt_360(SEXP data, SEXP format) +{ + SEXP x, sformat, ans; + int i, n = 0, m, N, nlen[9]; + char buff[300]; + struct tm tm; + + PROTECT(x = duplicate(data)); /* coerced below */ + if(!isVectorList(x) || LENGTH(x) != 9) + error(_("invalid '%s' argument"), "x"); + if(!isString((sformat = format)) || LENGTH(sformat) == 0) + error(_("invalid '%s' argument"), "format"); + m = LENGTH(sformat); + + /* workaround for glibc/FreeBSD/MacOS X bugs in strftime: they have + non-POSIX/C99 time zone components + */ + memset(&tm, 0, sizeof(tm)); + + /* coerce fields to integer or real, find length of longest one */ + for(i = 0; i < 9; i++) { + nlen[i] = LENGTH(VECTOR_ELT(x, i)); + if(nlen[i] > n) n = nlen[i]; + SET_VECTOR_ELT(x, i, coerceVector(VECTOR_ELT(x, i), + i > 0 ? INTSXP : REALSXP)); + } + if(n > 0) { + for(i = 0; i < 9; i++) + if(nlen[i] == 0) + error(_("zero length component in non-empty POSIXlt structure")); + } + if(n > 0) N = (m > n) ? m:n; else N = 0; + PROTECT(ans = allocVector(STRSXP, N)); + for(i = 0; i < N; i++) { + double secs = REAL(VECTOR_ELT(x, 0))[i%nlen[0]], fsecs = floor(secs); + tm.tm_sec = (int) fsecs; + tm.tm_min = INTEGER(VECTOR_ELT(x, 1))[i%nlen[1]]; + tm.tm_hour = INTEGER(VECTOR_ELT(x, 2))[i%nlen[2]]; + tm.tm_mday = INTEGER(VECTOR_ELT(x, 3))[i%nlen[3]]; + tm.tm_mon = INTEGER(VECTOR_ELT(x, 4))[i%nlen[4]]; + tm.tm_year = INTEGER(VECTOR_ELT(x, 5))[i%nlen[5]]; + tm.tm_wday = INTEGER(VECTOR_ELT(x, 6))[i%nlen[6]]; + tm.tm_yday = INTEGER(VECTOR_ELT(x, 7))[i%nlen[7]]; + tm.tm_isdst = INTEGER(VECTOR_ELT(x, 8))[i%nlen[8]]; + if(!R_FINITE(secs) || tm.tm_min == NA_INTEGER || + tm.tm_hour == NA_INTEGER || tm.tm_mday == NA_INTEGER || + tm.tm_mon == NA_INTEGER || tm.tm_year == NA_INTEGER) { + SET_STRING_ELT(ans, i, NA_STRING); + } else { + if(validate_tm(&tm) < 0) SET_STRING_ELT(ans, i, NA_STRING); + else { + const char *q = CHAR(STRING_ELT(sformat, i%m)); + int n = (int) strlen(q) + 50; + char buf2[n]; +#ifdef Win32 + /* We want to override Windows' TZ names */ + p = strstr(q, "%Z"); + if (p) { + memset(buf2, 0, n); + strncpy(buf2, q, p - q); + strcat(buf2, tzname[0]); + strcat(buf2, p+2); + } else +#endif + strcpy(buf2, q); + + /* Handle R-specific format %OSn, which for output + gives the seconds truncated to 0 <= n <= 6 decimal + places + */ + char* p = strstr(q, "%OS"); + if(p) { + /* FIXME some of this should be outside the loop */ + int ns, nused = 4; + char *p2 = strstr(buf2, "%OS"); + *p2 = '\0'; + ns = *(p+3) - '0'; + if(ns < 0 || ns > 9) { /* not a digit */ + ns = asInteger(GetOption1(install("digits.secs"))); + if(ns == NA_INTEGER) ns = 0; + nused = 3; + } + if(ns > 6) ns = 6; + if(ns > 0) { + /* truncate to avoid nuisances such as PR#14579 */ + double s = secs, t = pow(10.0, (double) ns); + s = ((int) (s*t))/t; + snprintf(p2, ns+3+1, "%0*.*f", ns+3, ns, s); + strcat(buf2, p+nused); + } else { + strcat(p2, "%S"); + strcat(buf2, p+nused); + } + } + strftime(buff, 256, buf2, &tm); + SET_STRING_ELT(ans, i, mkChar(buff)); + } + } + } + UNPROTECT(2); + return ans; +} + +static void glibc_fix(struct tm *tm, int *invalid) +{ + /* set mon and mday which glibc does not always set. + Use current year/... if none has been specified. + + Specifying mon but not mday nor yday is invalid. + */ + time_t t = time(NULL); + struct tm *tm0; + int tmp; +#ifndef HAVE_POSIX_LEAPSECONDS + t -= n_leapseconds; +#endif + tm0 = localtime(&t); + if(tm->tm_year == NA_INTEGER) tm->tm_year = tm0->tm_year; + if(tm->tm_mon != NA_INTEGER && tm->tm_mday != NA_INTEGER) return; + /* at least one of the month and the day of the month is missing */ + if(tm->tm_yday != NA_INTEGER) { + /* since we have yday, let that take precedence over mon/mday */ + int yday = tm->tm_yday, mon = 0; + while(yday >= (tmp = days_in_month[mon])) { + yday -= tmp; + mon++; + } + tm->tm_mon = mon; + tm->tm_mday = yday + 1; + } else { + if(tm->tm_mday == NA_INTEGER) { + if(tm->tm_mon != NA_INTEGER) { + *invalid = 1; + return; + } else tm->tm_mday = tm0->tm_mday; + } + if(tm->tm_mon == NA_INTEGER) tm->tm_mon = tm0->tm_mon; + } +} + + +SEXP do_strptime_360(SEXP data, SEXP format) +{ + SEXP x, sformat, ans, ansnames, klass, GMT; + int i, n, m, N, invalid, offset; + struct tm tm, tm2, *ptm = &tm; + double psecs = 0.0; + + if(!isString((x = data))) + error(_("invalid '%s' argument"), "x"); + if(!isString((sformat = format)) || LENGTH(sformat) == 0) + error(_("invalid '%s' argument"), "x"); + + n = LENGTH(x); m = LENGTH(sformat); + if(n > 0) N = (m > n)?m:n; else N = 0; + + PROTECT(ans = allocVector(VECSXP, 9)); + for(i = 0; i < 9; i++) + SET_VECTOR_ELT(ans, i, allocVector(i > 0 ? INTSXP : REALSXP, N)); + + PROTECT(ansnames = allocVector(STRSXP, 9)); + for(i = 0; i < 9; i++) + SET_STRING_ELT(ansnames, i, mkChar(ltnames[i])); + + + for(i = 0; i < N; i++) { + /* for glibc's sake. That only sets some unspecified fields, + sometimes. */ + tm.tm_sec = tm.tm_min = tm.tm_hour = 0; + tm.tm_year = tm.tm_mon = tm.tm_mday = tm.tm_yday = + tm.tm_wday = NA_INTEGER; + tm.tm_isdst = -1; + offset = NA_INTEGER; + invalid = STRING_ELT(x, i%n) == NA_STRING || + !strptime_360(CHAR(STRING_ELT(x, i%n)), + CHAR(STRING_ELT(sformat, i%m)), &tm, &psecs, &offset); + if(!invalid) { + /* Solaris sets missing fields to 0 */ + if(tm.tm_mday == 0) tm.tm_mday = NA_INTEGER; + if(tm.tm_mon == NA_INTEGER || tm.tm_mday == NA_INTEGER + || tm.tm_year == NA_INTEGER) + glibc_fix(&tm, &invalid); + tm.tm_isdst = -1; + if (offset != NA_INTEGER) { + /* we know the offset, but not the timezone + so all we can do is to convert to time_t, + adjust and convert back */ + double t0; + memcpy(&tm2, &tm, sizeof(struct tm)); + t0 = mktime0(&tm2, 0); + if (t0 != -1) { + t0 -= offset; /* offset = -0800 is Seattle */ + ptm = localtime0(&t0, 0, &tm2); + } else invalid = 1; + } else { + /* we do want to set wday, yday, isdst, but not to + adjust structure at DST boundaries */ + memcpy(&tm2, &tm, sizeof(struct tm)); + mktime0(&tm2, 0); /* set wday, yday, isdst */ + tm.tm_wday = tm2.tm_wday; + tm.tm_yday = tm2.tm_yday; + tm.tm_isdst = 0; + } + invalid = validate_tm(&tm) != 0; + } + makelt(ptm, ans, i, !invalid, psecs - floor(psecs)); + } + + setAttrib(ans, R_NamesSymbol, ansnames); + PROTECT(klass = allocVector(STRSXP, 2)); + SET_STRING_ELT(klass, 0, mkChar("POSIXlt")); + SET_STRING_ELT(klass, 1, mkChar("POSIXt")); + classgets(ans, klass); + GMT = PROTECT(mkString("GMT")); + setAttrib(ans, install("tzone"), GMT); + + UNPROTECT(4); + return ans; +} + +SEXP do_D2POSIXlt_360(SEXP data) +{ + SEXP x, ans, ansnames, klass, UTC; + int n, i, valid; + int day; + int y, tmp, mon; + struct tm tm; + + PROTECT(x = coerceVector(data, REALSXP)); + n = LENGTH(x); + PROTECT(ans = allocVector(VECSXP, 9)); + for(i = 0; i < 9; i++) + SET_VECTOR_ELT(ans, i, allocVector(i > 0 ? INTSXP : REALSXP, n)); + + PROTECT(ansnames = allocVector(STRSXP, 9)); + for(i = 0; i < 9; i++) + SET_STRING_ELT(ansnames, i, mkChar(ltnames[i])); + + for(i = 0; i < n; i++) { + if(R_FINITE(REAL(x)[i])) { + day = (int) floor(REAL(x)[i]); + tm.tm_hour = tm.tm_min = tm.tm_sec = 0; + /* weekday: 1970-01-01 was a Thursday */ + if ((tm.tm_wday = ((4 + day) % 7)) < 0) tm.tm_wday += 7; + + /* year & day within year */ + y = 1970; + if (day >= 0) + for ( ; day >= (tmp = days_in_year); day -= tmp, y++); + else + for ( ; day < 0; --y, day += days_in_year ); + + y = tm.tm_year = y - 1900; + tm.tm_yday = day; + + /* month within year */ + for (mon = 0; + day >= (tmp = (days_in_month[mon])); + day -= tmp, mon++); + tm.tm_mon = mon; + tm.tm_mday = day + 1; + tm.tm_isdst = 0; /* no dst in GMT */ + + valid = 1; + } else valid = 0; + makelt(&tm, ans, i, valid, 0.0); + } + setAttrib(ans, R_NamesSymbol, ansnames); + PROTECT(klass = allocVector(STRSXP, 2)); + SET_STRING_ELT(klass, 0, mkChar("POSIXlt")); + SET_STRING_ELT(klass, 1, mkChar("POSIXt")); + classgets(ans, klass); + UTC = PROTECT(mkString("UTC")); + setAttrib(ans, install("tzone"), UTC); + UNPROTECT(5); + + return ans; +} + +SEXP do_POSIXlt2D_360(SEXP data) +{ + SEXP x, ans, klass; + int i, n = 0, nlen[9]; + struct tm tm; + + PROTECT(x = duplicate(data)); + if(!isVectorList(x) || LENGTH(x) != 9) + error(_("invalid '%s' argument"), "x"); + + for(i = 3; i < 6; i++) + if((nlen[i] = LENGTH(VECTOR_ELT(x, i))) > n) n = nlen[i]; + if((nlen[8] = LENGTH(VECTOR_ELT(x, 8))) > n) n = nlen[8]; + if(n > 0) { + for(i = 3; i < 6; i++) + if(nlen[i] == 0) + error(_("zero length component in non-empty POSIXlt structure")); + if(nlen[8] == 0) + error(_("zero length component in non-empty POSIXlt structure")); + } + /* coerce relevant fields to integer */ + for(i = 3; i < 6; i++) + SET_VECTOR_ELT(x, i, coerceVector(VECTOR_ELT(x, i), INTSXP)); + + PROTECT(ans = allocVector(REALSXP, n)); + for(i = 0; i < n; i++) { + tm.tm_sec = tm.tm_min = tm.tm_hour = 0; + tm.tm_mday = INTEGER(VECTOR_ELT(x, 3))[i%nlen[3]]; + tm.tm_mon = INTEGER(VECTOR_ELT(x, 4))[i%nlen[4]]; + tm.tm_year = INTEGER(VECTOR_ELT(x, 5))[i%nlen[5]]; + /* mktime ignores tm.tm_wday and tm.tm_yday */ + tm.tm_isdst = 0; + if(tm.tm_mday == NA_INTEGER || tm.tm_mon == NA_INTEGER || + tm.tm_year == NA_INTEGER || validate_tm(&tm) < 0) + REAL(ans)[i] = NA_REAL; + else { + /* -1 must be error as seconds were zeroed */ + double tmp = mktime00(&tm); + REAL(ans)[i] = (tmp == -1) ? NA_REAL : tmp/86400; + } + } + + PROTECT(klass = mkString("Date")); + classgets(ans, klass); + UNPROTECT(3); + return ans; +} + +void R_unload_mylib(DllInfo* info) { +} diff --git a/src/datetime_360.o b/src/datetime_360.o new file mode 100644 index 0000000000000000000000000000000000000000..a2a9f6f268111fffd89acec487551fab0ee79ef4 Binary files /dev/null and b/src/datetime_360.o differ diff --git a/src/strptime_360.h b/src/strptime_360.h new file mode 100644 index 0000000000000000000000000000000000000000..55c361a04aa05fa4533d0d3a2cbd31ea518e9000 --- /dev/null +++ b/src/strptime_360.h @@ -0,0 +1,1249 @@ +/* For inclusion by datetime.c. + + A modified version of code from the GNU C library with locale + support removed and wchar support added. +*/ + +/* Convert a string representation of time to a time value. + Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. + This file is part of the GNU C Library. + Contributed by Ulrich Drepper , 1996. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with the GNU C Library; see the file COPYING.LIB. If not, + a copy is available at http://www.r-project.org/licenses/ +*/ +/* XXX This version of the implementation is not really complete. + Some of the fields cannot add information alone. But if seeing + some of them in the same format (such as year, week and weekday) + this is enough information for determining the date. */ + +/* #include +#include +#include */ + +#ifdef ENABLE_NLS +#include +#ifdef Win32 +#define _(String) libintl_gettext (String) +#undef gettext /* needed for graphapp */ +#else +#define _(String) gettext (String) +#endif +#define gettext_noop(String) String +#define N_(String) gettext_noop (String) +#else /* not NLS */ +#define _(String) (String) +#define N_(String) String +#define ngettext(String, StringP, N) (N > 1 ? StringP: String) +#endif + +/* This is C90 */ +#ifndef HAVE_LOCALE_H +# define HAVE_LOCALE_H 1 +#endif +#ifdef HAVE_STRINGS_H +#include /* for strncasecmp */ +#endif + +#include /* for isspace */ + +#define match_char(ch1, ch2) if (ch1 != ch2) return NULL + +/* we guarantee to have strncasecmp in R */ +#if defined __GNUC__ && __GNUC__ >= 2 +# define match_string(cs1, s2) \ + (__extension__ ({ size_t len = strlen (cs1); \ + int result = strncasecmp ((cs1), (s2), len) == 0; \ + if (result) (s2) += len; \ + result; })) +#else +/* Oh come on. Get a reasonable compiler. */ +# define match_string(cs1, s2) \ + (strncasecmp ((cs1), (s2), strlen (cs1)) ? 0 : ((s2) += strlen (cs1), 1)) +#endif + +/* We intentionally do not use isdigit() for testing because this will + lead to problems with the wide character version. */ +#define get_number(from, to, n) \ + do { \ + int __n = n; \ + val = 0; \ + while (*rp == ' ') \ + ++rp; \ + if (*rp < '0' || *rp > '9') \ + return NULL; \ + do { \ + val *= 10; \ + val += *rp++ - '0'; \ +/* } while (--__n > 0 && val * 10 <= to && *rp >= '0' && *rp <= '9');*/ \ + } while (--__n > 0 && *rp >= '0' && *rp <= '9'); \ + if (val < from || val > to) \ + return NULL; \ + } while (0) +# define get_alt_number(from, to, n) \ + /* We don't have the alternate representation. */ \ + get_number(from, to, n) +#define recursive(new_fmt) \ + (*(new_fmt) != '\0' \ + && (rp = strptime_internal (rp, (new_fmt), tm, decided, psecs, poffset)) != NULL) + +/* This version: may overwrite these with versions for the locale, + * hence the extra length of the fields + */ +static char weekday_name[][20] = +{ + "Sunday", "Monday", "Tuesday", "Wednesday", + "Thursday", "Friday", "Saturday" +}; +static char ab_weekday_name[][10] = +{ + "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" +}; +static char month_name[][20] = +{ + "January", "February", "March", "April", "May", "June", + "July", "August", "September", "October", "November", "December" +}; +static char ab_month_name[][10] = +{ + "Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" +}; + +static char am_pm[][4] = {"AM", "PM"}; + + +# define HERE_D_T_FMT "%a %b %e %H:%M:%S %Y" +# define HERE_D_FMT "%y/%m/%d" +# define HERE_T_FMT_AMPM "%I:%M:%S %p" +# define HERE_T_FMT "%H:%M:%S" + +static const unsigned short int __mon_yday[13] = +{ 0, 30, 60, 90, 120, 150, 180, 210, 240, 270, 300, 330, 360 }; + + +/* Status of lookup: do we use the locale data or the raw data? */ +enum locale_status { Not, loc, raw }; + +/* Compute the day of the week. */ +static void +day_of_the_week (struct tm *tm) +{ + /* We know that January 1st 1970 was a Thursday (= 4). Compute the + the difference between this data in the one on TM and so determine + the weekday. */ + int corr_year, wday; + + /* R bug fix: day_of_the_week needs year, month, mday set */ + if(tm->tm_year == NA_INTEGER || + tm->tm_mon == NA_INTEGER || + tm->tm_mday == NA_INTEGER) return; + + corr_year = 1900 + tm->tm_year - (tm->tm_mon < 2); + wday = (-473 + + (365 * (tm->tm_year - 70)) + + (corr_year / 4) + - ((corr_year / 4) / 25) + ((corr_year / 4) % 25 < 0) + + (((corr_year / 4) / 25) / 4) + + __mon_yday[tm->tm_mon] + + tm->tm_mday - 1); + tm->tm_wday = ((wday % 7) + 7) % 7; +} + +/* Compute the day of the year. */ +static void +day_of_the_year (struct tm *tm) +{ + /* R bug fix: day_of_the_year needs year, month, mday set */ + if(tm->tm_year == NA_INTEGER || + tm->tm_mon == NA_INTEGER || + tm->tm_mday == NA_INTEGER) return; + + tm->tm_yday = (__mon_yday[tm->tm_mon] + + (tm->tm_mday - 1)); +} + +#include +#include + +static wchar_t w_weekday_name[][20] = +{ + L"Sunday", L"Monday", L"Tuesday", L"Wednesday", + L"Thursday", L"Friday", L"Saturday" +}; +static wchar_t w_ab_weekday_name[][10] = +{ + L"Sun", L"Mon", L"Tue", L"Wed", L"Thu", L"Fri", L"Sat" +}; +static wchar_t w_month_name[][20] = +{ + L"January", L"February", L"March", L"April", L"May", L"June", + L"July", L"August", L"September", L"October", L"November", L"December" +}; +static wchar_t w_ab_month_name[][10] = +{ + L"Jan", L"Feb", L"Mar", L"Apr", L"May", L"Jun", + L"Jul", L"Aug", L"Sep", L"Oct", L"Nov", L"Dec" +}; + +static wchar_t w_am_pm[][4] = {L"AM", L"PM"}; + +/* Need case-insensitive version */ +static int Rwcsncasecmp(const wchar_t *cs1, const wchar_t *s2) +{ + size_t i, n = wcslen(cs1); + const wchar_t *a = cs1, *b = s2; + for(i = 0; i < n; i++, a++, b++) { + if(*b == L'\0' || towlower(*a) != towlower(*b)) return 1; + } + return 0; +} + +#define w_match_string(cs1, s2) \ + (Rwcsncasecmp ((cs1), (s2)) ? 0 : ((s2) += wcslen (cs1), 1)) + +#define w_recursive(new_fmt) \ + (*(new_fmt) != '\0' \ + && (rp = w_strptime_internal (rp, (new_fmt), tm, decided, psecs, poffset)) != NULL) + +static inline wchar_t * +w_strptime_internal (wchar_t *rp, const wchar_t *fmt, struct tm *tm, + enum locale_status *decided, double *psecs, + int *poffset) +{ + int cnt; + int val; + int have_I, is_pm; + int century, want_century; + int have_wday, want_xday; + int have_yday; + int have_mon, have_mday; + int have_uweek, have_wweek; + int week_no = 0; /* -Wall */ + + have_I = is_pm = 0; + century = -1; + want_century = 0; + have_wday = want_xday = have_yday = have_mon = have_mday = 0; + have_uweek = have_wweek = 0; + + while (*fmt != L'\0') + { + /* A white space in the format string matches 0 more or white + space in the input string. */ + if (iswspace (*fmt)) + { + while (iswspace (*rp)) + ++rp; + ++fmt; + continue; + } + + /* Any character but `%' must be matched by the same character + in the input string. */ + if (*fmt != L'%') + { + match_char (*fmt++, *rp++); + continue; + } + + ++fmt; + + /* We need this for handling the `E' modifier. */ + start_over: + + switch (*fmt++) + { + case L'%': + /* Match the `%' character itself. */ + match_char (L'%', *rp++); + break; + case L'a': + case L'A': + /* Match day of week. */ + for (cnt = 0; cnt < 7; ++cnt) + { + if (*decided != loc + && (w_match_string (w_weekday_name[cnt], rp) + || w_match_string (w_ab_weekday_name[cnt], rp))) + { + *decided = raw; + break; + } + } + if (cnt == 7) + /* Does not match a weekday name. */ + return NULL; + tm->tm_wday = cnt; + have_wday = 1; + break; + case L'b': + case L'B': + case L'h': + /* Match month name. */ + for (cnt = 0; cnt < 12; ++cnt) + { + if (w_match_string (w_month_name[cnt], rp) + || w_match_string (w_ab_month_name[cnt], rp)) + { + *decided = raw; + break; + } + } + if (cnt == 12) + /* Does not match a month name. */ + return NULL; + tm->tm_mon = cnt; + want_xday = 1; + break; + case L'c': + /* Match locale's date and time format. */ + if (!w_recursive (L"%a %b %e %H:%M:%S %Y")) /* HERE_D_T_FMT */ + return NULL; + break; + case L'C': + /* Match century number. */ + get_number (0, 99, 2); + century = val; + want_xday = 1; + break; + case L'd': + case L'e': + /* Match day of month. */ + get_number (1, 31, 2); + tm->tm_mday = val; + have_mday = 1; + want_xday = 1; + break; + case L'F': + if (!w_recursive (L"%Y-%m-%d")) + return NULL; + want_xday = 1; + break; + case L'x': + /* Fall through. */ + case L'D': + /* Match standard day format. */ + if (!w_recursive (L"%y/%m/%d")) /* HERE_D_FMT */ + return NULL; + want_xday = 1; + break; + case L'k': + case L'H': + /* Match hour in 24-hour clock. */ + get_number (0, 24, 2); /* allow 24:00:00 */ + tm->tm_hour = val; + have_I = 0; + break; + case L'l': + /* Match hour in 12-hour clock. GNU extension. */ + case L'I': + /* Match hour in 12-hour clock. */ + get_number (1, 12, 2); + tm->tm_hour = val % 12; + have_I = 1; + break; + case L'j': + /* Match day number of year. */ + get_number (1, 366, 3); + tm->tm_yday = val - 1; + have_yday = 1; + break; + case L'm': + /* Match number of month. */ + get_number (1, 12, 2); + tm->tm_mon = val - 1; + have_mon = 1; + want_xday = 1; + break; + case L'M': + /* Match minute. */ + get_number (0, 59, 2); + tm->tm_min = val; + break; + case L'n': + case L't': + /* Match any white space. */ + while (iswspace (*rp)) + ++rp; + break; + case L'p': + /* Match locale's equivalent of AM/PM. */ + if (!w_match_string (w_am_pm[0], rp)) { + if (w_match_string (w_am_pm[1], rp)) + is_pm = 1; + else + return NULL; + } + break; + case L'r': + if (!w_recursive (L"%I:%M:%S %p")) /* HERE_T_FMT_AMPM */ + return NULL; + break; + case L'R': + if (!w_recursive (L"%H:%M")) + return NULL; + break; + case L's': + { + /* The number of seconds may be very high so we cannot use + the `get_number' macro. Instead read the number + character for character and construct the result while + doing this. */ + time_t secs = 0; + if (*rp < L'0' || *rp > L'9') + /* We need at least one digit. */ + return NULL; + + do + { + secs *= 10; + secs += *rp++ - L'0'; + } + while (*rp >= L'0' && *rp <= L'9'); + + if ((tm = localtime (&secs)) == NULL) + /* Error in function. */ + return NULL; + } + break; + case L'S': + get_number (0, 61, 2); + tm->tm_sec = val; + break; + case L'X': + /* Fall through. */ + case L'T': + if (!w_recursive (L"%H:%M:%S")) /* HERE_T_FMT */ + return NULL; + break; + case L'u': + get_number (1, 7, 1); + tm->tm_wday = val % 7; + have_wday = 1; + break; + case L'g': + get_number (0, 99, 2); + /* XXX This cannot determine any field in TM. */ + break; + case L'G': + if (*rp < L'0' || *rp > L'9') + return NULL; + /* XXX Ignore the number since we would need some more + information to compute a real date. */ + do + ++rp; + while (*rp >= L'0' && *rp <= L'9'); + break; + case L'U': + get_number (0, 53, 2); + week_no = val; + have_uweek = 1; + break; + case L'W': + get_number (0, 53, 2); + week_no = val; + have_wweek = 1; + break; + case L'V': + get_number (0, 53, 2); + /* XXX This cannot determine any field in TM without some + information. */ + break; + case L'w': + /* Match number of weekday. */ + get_number (0, 6, 1); + tm->tm_wday = val; + have_wday = 1; + break; + case L'y': + /* Match year within century. */ + get_number (0, 99, 2); + /* The "Year 2000: The Millennium Rollover" paper suggests that + values in the range 69-99 refer to the twentieth century. */ + int ival = val; + tm->tm_year = ival >= 69 ? ival : ival + 100; + /* Indicate that we want to use the century, if specified. */ + want_century = 1; + want_xday = 1; + break; + case L'Y': + /* Match year including century number. */ + get_number (0, 9999, 4); + tm->tm_year = val - 1900; + want_century = 0; + want_xday = 1; + break; + case L'z': + { + int n = 0, neg, off = 0; + val = 0; + while (*rp == L' ') ++rp; + if (*rp != L'+' && *rp != L'-') return NULL; + neg = *rp++ == L'-'; + while (n < 4 && *rp >= L'0' && *rp <= L'9') { + val = val * 10 + *rp++ - L'0'; + ++n; + } + if (n != 4) return NULL; + else { + /* We have to convert the minutes into decimal. */ + if (val % 100 >= 60) return NULL; + val = (val / 100) * 100 + ((val % 100) * 50) / 30; + } + if (val > 1200) return NULL; + off = ((val * 3600) / 100); + if (neg) off = -off; + *poffset = off; + } + break; + case L'Z': + error(_("use of %s for input is not supported"), "%Z"); + return NULL; + break; + case L'E': + /* We have no information about the era format. Just use + the normal format. */ + if (*fmt != L'c' && *fmt != L'C' && *fmt != L'y' && *fmt != L'Y' + && *fmt != L'x' && *fmt != L'X') + /* This is an illegal format. */ + return NULL; + + goto start_over; + case L'O': + switch (*fmt++) + { + case L'd': + case L'e': + /* Match day of month using alternate numeric symbols. */ + get_alt_number (1, 31, 2); + tm->tm_mday = val; + have_mday = 1; + want_xday = 1; + break; + case L'H': + /* Match hour in 24-hour clock using alternate numeric + symbols. */ + get_alt_number (0, 23, 2); + tm->tm_hour = val; + have_I = 0; + break; + case L'I': + /* Match hour in 12-hour clock using alternate numeric + symbols. */ + get_alt_number (1, 12, 2); + tm->tm_hour = val % 12; + have_I = 1; + break; + case L'm': + /* Match month using alternate numeric symbols. */ + get_alt_number (1, 12, 2); + tm->tm_mon = val - 1; + have_mon = 1; + want_xday = 1; + break; + case L'M': + /* Match minutes using alternate numeric symbols. */ + get_alt_number (0, 59, 2); + tm->tm_min = val; + break; + case L'S': + /* Match seconds using alternate numeric symbols. + get_alt_number (0, 61, 2); */ + { + double sval; + wchar_t *end; + sval = wcstod(rp, &end); + if( sval >= 0.0 && sval <= 61.0) { + tm->tm_sec = (int) sval; + *psecs = sval; + } + rp = end; + } + break; + case L'U': + get_alt_number (0, 53, 2); + week_no = val; + have_uweek = 1; + break; + case L'W': + get_alt_number (0, 53, 2); + week_no = val; + have_wweek = 1; + break; + case L'V': + get_alt_number (0, 53, 2); + /* XXX This cannot determine any field in TM without + further information. */ + break; + case L'w': + /* Match number of weekday using alternate numeric symbols. */ + get_alt_number (0, 6, 1); + tm->tm_wday = val; + have_wday = 1; + break; + case L'y': + /* Match year within century using alternate numeric symbols. */ + get_alt_number (0, 99, 2); + int ival = val; + tm->tm_year = ival >= 69 ? ival : ival + 100; + want_xday = 1; + break; + default: + return NULL; + } + break; + default: + return NULL; + } + } + + if (have_I && is_pm) + tm->tm_hour += 12; + + if (century != -1) + { + if (want_century) + tm->tm_year = tm->tm_year % 100 + (century - 19) * 100; + else + /* Only the century, but not the year. Strange, but so be it. */ + tm->tm_year = (century - 19) * 100; + } + + if (want_xday && !have_wday) { + if ( !(have_mon && have_mday) && have_yday) { + /* We don't have tm_mon and/or tm_mday, compute them. */ + int t_mon = 0; + while (__mon_yday[t_mon] <= tm->tm_yday) + t_mon++; + if (!have_mon) + tm->tm_mon = t_mon - 1; + if (!have_mday) + tm->tm_mday = (tm->tm_yday - __mon_yday[t_mon - 1] + 1); + } + day_of_the_week (tm); + } + + if (want_xday && !have_yday) + day_of_the_year (tm); + + if ((have_uweek || have_wweek) && have_wday) { + int save_wday = tm->tm_wday; + int save_mday = tm->tm_mday; + int save_mon = tm->tm_mon; + int w_offset = have_uweek ? 0 : 1; + + tm->tm_mday = 1; + tm->tm_mon = 0; + day_of_the_week (tm); + if (have_mday) + tm->tm_mday = save_mday; + if (have_mon) + tm->tm_mon = save_mon; + + if (!have_yday) + tm->tm_yday = ((7 - (tm->tm_wday - w_offset)) % 7 + + (week_no - 1) *7 + + save_wday - w_offset); + + if (!have_mday || !have_mon) + { + int t_mon = 0; + while (__mon_yday[t_mon] + <= tm->tm_yday) + t_mon++; + if (!have_mon) + tm->tm_mon = t_mon - 1; + if (!have_mday) + tm->tm_mday = + (tm->tm_yday + - __mon_yday[t_mon - 1] + 1); + } + + tm->tm_wday = save_wday; + } + + return rp; +} + + +static char * +strptime_internal (const char *rp, const char *fmt, struct tm *tm, + enum locale_status *decided, double *psecs, + int *poffset) +{ + int cnt; + int val; + int have_I, is_pm; + int century, want_century; + int have_wday, want_xday; + int have_yday; + int have_mon, have_mday; + int have_uweek, have_wweek; + int week_no = 0; /* -Wall */ + + have_I = is_pm = 0; + century = -1; + want_century = 0; + have_wday = want_xday = have_yday = have_mon = have_mday = 0; + have_uweek = have_wweek = 0; + + while (*fmt != '\0') + { + /* A white space in the format string matches 0 more or white + space in the input string. */ + if (isspace ((int)*fmt)) + { + while (isspace ((int)*rp)) + ++rp; + ++fmt; + continue; + } + + /* Any character but `%' must be matched by the same character + in the input string. */ + if (*fmt != '%') + { + match_char (*fmt++, *rp++); + continue; + } + + ++fmt; + + /* We need this for handling the `E' modifier. */ + start_over: + + switch (*fmt++) + { + case '%': + /* Match the `%' character itself. */ + match_char ('%', *rp++); + break; + case 'a': + case 'A': + /* Match day of week. */ + for (cnt = 0; cnt < 7; ++cnt) + { + if (*decided != loc + && (match_string (weekday_name[cnt], rp) + || match_string (ab_weekday_name[cnt], rp))) + { + *decided = raw; + break; + } + } + if (cnt == 7) + /* Does not match a weekday name. */ + return NULL; + tm->tm_wday = cnt; + have_wday = 1; + break; + case 'b': + case 'B': + case 'h': + /* Match month name. */ + for (cnt = 0; cnt < 12; ++cnt) + { + if (match_string (month_name[cnt], rp) + || match_string (ab_month_name[cnt], rp)) + { + *decided = raw; + break; + } + } + if (cnt == 12) + /* Does not match a month name. */ + return NULL; + tm->tm_mon = cnt; + want_xday = 1; + break; + case 'c': + /* Match locale's date and time format. */ + if (!recursive (HERE_D_T_FMT)) + return NULL; + break; + case 'C': + /* Match century number. */ + get_number (0, 99, 2); + century = val; + want_xday = 1; + break; + case 'd': + case 'e': + /* Match day of month. */ + get_number (1, 31, 2); + tm->tm_mday = val; + have_mday = 1; + want_xday = 1; + break; + case 'F': + if (!recursive ("%Y-%m-%d")) + return NULL; + want_xday = 1; + break; + case 'x': + /* Fall through. */ + case 'D': + /* Match standard day format. */ + if (!recursive (HERE_D_FMT)) + return NULL; + want_xday = 1; + break; + case 'k': + case 'H': + /* Match hour in 24-hour clock. */ + get_number (0, 24, 2); /* allow 24:00:00 */ + tm->tm_hour = val; + have_I = 0; + break; + case 'l': + /* Match hour in 12-hour clock. GNU extension. */ + case 'I': + /* Match hour in 12-hour clock. */ + get_number (1, 12, 2); + tm->tm_hour = val % 12; + have_I = 1; + break; + case 'j': + /* Match day number of year. */ + get_number (1, 366, 3); + tm->tm_yday = val - 1; + have_yday = 1; + break; + case 'm': + /* Match number of month. */ + get_number (1, 12, 2); + tm->tm_mon = val - 1; + have_mon = 1; + want_xday = 1; + break; + case 'M': + /* Match minute. */ + get_number (0, 59, 2); + tm->tm_min = val; + break; + case 'n': + case 't': + /* Match any white space. */ + while (isspace ((int)*rp)) + ++rp; + break; + case 'p': + /* Match locale's equivalent of AM/PM. */ + if (!match_string (am_pm[0], rp)) { + if (match_string (am_pm[1], rp)) + is_pm = 1; + else + return NULL; + } + break; + case 'r': + if (!recursive (HERE_T_FMT_AMPM)) + return NULL; + break; + case 'R': + if (!recursive ("%H:%M")) + return NULL; + break; + case 's': + { + /* The number of seconds may be very high so we cannot use + the `get_number' macro. Instead read the number + character for character and construct the result while + doing this. */ + time_t secs = 0; + if (*rp < '0' || *rp > '9') + /* We need at least one digit. */ + return NULL; + + do + { + secs *= 10; + secs += *rp++ - '0'; + } + while (*rp >= '0' && *rp <= '9'); + + if ((tm = localtime (&secs)) == NULL) + /* Error in function. */ + return NULL; + } + break; + case 'S': + get_number (0, 61, 2); + tm->tm_sec = val; + break; + case 'X': + /* Fall through. */ + case 'T': + if (!recursive (HERE_T_FMT)) + return NULL; + break; + case 'u': + get_number (1, 7, 1); + tm->tm_wday = val % 7; + have_wday = 1; + break; + case 'g': + get_number (0, 99, 2); + /* XXX This cannot determine any field in TM. */ + break; + case 'G': + if (*rp < '0' || *rp > '9') + return NULL; + /* XXX Ignore the number since we would need some more + information to compute a real date. */ + do + ++rp; + while (*rp >= '0' && *rp <= '9'); + break; + case 'U': + get_number (0, 53, 2); + week_no = val; + have_uweek = 1; + break; + case 'W': + get_number (0, 53, 2); + week_no = val; + have_wweek = 1; + break; + case 'V': + get_number (0, 53, 2); + /* XXX This cannot determine any field in TM without some + information. */ + break; + case 'w': + /* Match number of weekday. */ + get_number (0, 6, 1); + tm->tm_wday = val; + have_wday = 1; + break; + case 'y': + /* Match year within century. */ + get_number (0, 99, 2); + /* The "Year 2000: The Millennium Rollover" paper suggests that + values in the range 69-99 refer to the twentieth century. + And this is mandated by the POSIX 2001 standard, with a + caveat that it might change in future. + */ + int ival = val; + tm->tm_year = ival >= 69 ? ival : ival + 100; + /* Indicate that we want to use the century, if specified. */ + want_century = 1; + want_xday = 1; + break; + case 'Y': + /* Match year including century number. */ + get_number (0, 9999, 4); + tm->tm_year = val - 1900; + want_century = 0; + want_xday = 1; + break; + case 'z': + /* Only recognize RFC 822 form */ + { + int n = 0, neg, off = 0; + val = 0; + while (*rp == ' ') ++rp; + if (*rp != '+' && *rp != '-') return NULL; + neg = *rp++ == '-'; + while (n < 4 && *rp >= '0' && *rp <= '9') { + val = val * 10 + *rp++ - '0'; + ++n; + } + if (n != 4) return NULL; + else { + /* We have to convert the minutes into decimal. */ + if (val % 100 >= 60) return NULL; + val = (val / 100) * 100 + ((val % 100) * 50) / 30; + } + if (val > 1200) return NULL; + off = (val * 3600) / 100; + if (neg) off = -off; + *poffset = off; + } + break; + case 'Z': + error(_("use of %s for input is not supported"), "%Z"); + return NULL; + break; + case 'E': + /* We have no information about the era format. Just use + the normal format. */ + if (*fmt != 'c' && *fmt != 'C' && *fmt != 'y' && *fmt != 'Y' + && *fmt != 'x' && *fmt != 'X') + /* This is an illegal format. */ + return NULL; + + goto start_over; + case 'O': + switch (*fmt++) + { + case 'd': + case 'e': + /* Match day of month using alternate numeric symbols. */ + get_alt_number (1, 31, 2); + tm->tm_mday = val; + have_mday = 1; + want_xday = 1; + break; + case 'H': + /* Match hour in 24-hour clock using alternate numeric + symbols. */ + get_alt_number (0, 23, 2); + tm->tm_hour = val; + have_I = 0; + break; + case 'I': + /* Match hour in 12-hour clock using alternate numeric + symbols. */ + get_alt_number (1, 12, 2); + tm->tm_hour = val % 12; + have_I = 1; + break; + case 'm': + /* Match month using alternate numeric symbols. */ + get_alt_number (1, 12, 2); + tm->tm_mon = val - 1; + have_mon = 1; + want_xday = 1; + break; + case 'M': + /* Match minutes using alternate numeric symbols. */ + get_alt_number (0, 59, 2); + tm->tm_min = val; + break; + case 'S': + /* Match seconds using alternate numeric symbols. + get_alt_number (0, 61, 2); */ + { + double sval; + char *end; + sval = strtod(rp, &end); + if( sval >= 0.0 && sval <= 61.0) { + tm->tm_sec = (int) sval; + *psecs = sval; + } + rp = end; + } + break; + case 'U': + get_alt_number (0, 53, 2); + week_no = val; + have_uweek = 1; + break; + case 'W': + get_alt_number (0, 53, 2); + week_no = val; + have_wweek = 1; + break; + case 'V': + get_alt_number (0, 53, 2); + /* XXX This cannot determine any field in TM without + further information. */ + break; + case 'w': + /* Match number of weekday using alternate numeric symbols. */ + get_alt_number (0, 6, 1); + tm->tm_wday = val; + have_wday = 1; + break; + case 'y': + /* Match year within century using alternate numeric symbols. */ + get_alt_number (0, 99, 2); + int ival = val; + tm->tm_year = ival >= 69 ? ival : ival + 100; + want_xday = 1; + break; + default: + return NULL; + } + break; + default: + return NULL; + } + } + + if (have_I && is_pm) + tm->tm_hour += 12; + + if (century != -1) + { + if (want_century) + tm->tm_year = tm->tm_year % 100 + (century - 19) * 100; + else + /* Only the century, but not the year. Strange, but so be it. */ + tm->tm_year = (century - 19) * 100; + } + + if (want_xday && !have_wday) { + if ( !(have_mon && have_mday) && have_yday) { + /* We don't have tm_mon and/or tm_mday, compute them. */ + int t_mon = 0; + while (__mon_yday[t_mon] <= tm->tm_yday) + t_mon++; + if (!have_mon) + tm->tm_mon = t_mon - 1; + if (!have_mday) + tm->tm_mday = (tm->tm_yday - __mon_yday[t_mon - 1] + 1); + } + day_of_the_week (tm); + } + + if (want_xday && !have_yday) + day_of_the_year (tm); + + if ((have_uweek || have_wweek) && have_wday) { + int save_wday = tm->tm_wday; + int save_mday = tm->tm_mday; + int save_mon = tm->tm_mon; + int w_offset = have_uweek ? 0 : 1; + + tm->tm_mday = 1; + tm->tm_mon = 0; + day_of_the_week (tm); + if (have_mday) + tm->tm_mday = save_mday; + if (have_mon) + tm->tm_mon = save_mon; + + if (!have_yday) + tm->tm_yday = ((7 - (tm->tm_wday - w_offset)) % 7 + + (week_no - 1) *7 + + save_wday - w_offset); + + if (!have_mday || !have_mon) + { + int t_mon = 0; + while (__mon_yday[t_mon] + <= tm->tm_yday) + t_mon++; + if (!have_mon) + tm->tm_mon = t_mon - 1; + if (!have_mday) + tm->tm_mday = + (tm->tm_yday + - __mon_yday[t_mon - 1] + 1); + } + + tm->tm_wday = save_wday; + } + + return (char *) rp; +} + + +#ifdef HAVE_LOCALE_H +# include + +/* We check for a changed locale here, as setting the locale strings is + on some systems slow compared to the conversions. */ + +static void get_locale_strings(void) +{ + int i; + struct tm tm; + char buff[4]; + + tm.tm_sec = tm.tm_min = tm.tm_hour = tm.tm_mday = tm.tm_mon + = tm.tm_isdst = 0; + tm.tm_year = 30; + for(i = 0; i < 12; i++) { + tm.tm_mon = i; + strftime(ab_month_name[i], 10, "%b", &tm); + strftime(month_name[i], 20, "%B", &tm); + } + tm.tm_mon = 0; + for(i = 0; i < 7; i++) { + tm.tm_mday = tm.tm_yday = i+1; /* 2000-1-2 was a Sunday */ + tm.tm_wday = i; + strftime(ab_weekday_name[i], 10, "%a", &tm); + strftime(weekday_name[i], 20, "%A", &tm); + } + tm.tm_hour = 1; + /* in locales where these are unused, they may be empty: better + not to reset them then */ + strftime(buff, 4, "%p", &tm); + if(strlen(buff)) strcpy(am_pm[0], buff); + tm.tm_hour = 13; + strftime(buff, 4, "%p", &tm); + if(strlen(buff)) strcpy(am_pm[1], buff); +} + +#if defined(HAVE_WCSTOD) && defined(HAVE_WCSFTIME) +static void get_locale_w_strings(void) +{ + int i; + struct tm tm; + wchar_t buff[4]; + + tm.tm_sec = tm.tm_min = tm.tm_hour = tm.tm_mday = tm.tm_mon + = tm.tm_isdst = 0; + tm.tm_year = 30; + for(i = 0; i < 12; i++) { + tm.tm_mon = i; + wcsftime(w_ab_month_name[i], 10, L"%b", &tm); + wcsftime(w_month_name[i], 20, L"%B", &tm); + } + tm.tm_mon = 0; + for(i = 0; i < 7; i++) { + tm.tm_mday = tm.tm_yday = i+1; /* 2000-1-2 was a Sunday */ + tm.tm_wday = i; + wcsftime(w_ab_weekday_name[i], 10, L"%a", &tm); + wcsftime(w_weekday_name[i], 20, L"%A", &tm); + } + tm.tm_hour = 1; + /* in locales where these are unused, they may be empty: better + not to reset them then */ + wcsftime(buff, 4, L"%p", &tm); + if(wcslen(buff)) wcscpy(w_am_pm[0], buff); + tm.tm_hour = 13; + wcsftime(buff, 4, L"%p", &tm); + if(wcslen(buff)) wcscpy(w_am_pm[1], buff); +} +#endif +#endif /* HAVE_LOCALE_H */ + + +/* We only care if the result is null or not */ +static char * +strptime_360(const char *buf, const char *format, struct tm *tm, + double *psecs, int *poffset) +{ + enum locale_status decided; + decided = raw; +#if defined(HAVE_WCSTOD) + if(mbcslocale) { + wchar_t wbuf[1001], wfmt[1001]; size_t n; +#if defined(HAVE_LOCALE_H) && defined(HAVE_WCSFTIME) + get_locale_w_strings(); +#endif + n = mbstowcs(NULL, buf, 1000); + if(n > 1000) error(_("input string is too long")); + n = mbstowcs(wbuf, buf, 1000); + if(n == -1) error(_("invalid multibyte input string")); + + n = mbstowcs(NULL, format, 1000); + if(n > 1000) error(_("format string is too long")); + n = mbstowcs(wfmt, format, 1000); + if(n == -1) error(_("invalid multibyte format string")); + return (char *) w_strptime_internal (wbuf, wfmt, tm, &decided, psecs, poffset); + } else +#endif + { +#ifdef HAVE_LOCALE_H + get_locale_strings(); +#endif + return strptime_internal (buf, format, tm, &decided, psecs, poffset); + } +}