PCICt/0000755000175100001440000000000013265135314011175 5ustar hornikusersPCICt/tests/0000755000175100001440000000000012162700306012331 5ustar hornikusersPCICt/tests/bootstrap.R0000644000175100001440000000046512162677501014510 0ustar hornikusers if(require("RUnit", quietly=TRUE)) { ## Run all the tests wd <- getwd() testsuite <- defineTestSuite("PCICt", dirs=wd, testFileRegexp = "^test_functions.R$", testFuncRegexp = "^PCICt.test.+") PCICt.test.result <- runTestSuite(testsuite, useOwnErrorHandler=F) printTextProtocol(PCICt.test.result) } PCICt/tests/test_functions.R0000644000175100001440000001533512020027033015522 0ustar hornikuserslibrary(PCICt) library(RUnit) test.values <- c("1850-01-01", "2012-04-01 00:10:00", "2012-02-28", "1599-01-01", "1582-10-04", "1582-10-03", "900-02-28", "900-03-01", "200-03-01", "1-01-01", "0-01-01") ## Tests as.pcict functions PCICt.test.as.PCICt <- function() { test.calendars <- c("360", "365", "gregorian", "proleptic_gregorian") cal.360.only <- c("2011-02-30") gregorian.not.365 <- c("2012-02-29") gregorian.not.360 <- c("2011-01-31") ## Check that valid input produces valid output for all calendar types for(cal in test.calendars) { for(i in seq_along(test.values)) { checkEquals(as.character(as.PCICt(test.values[i], cal=cal)), test.values[i]) ## Check that as.PCICt.POSIXlt works as expected checkEquals(as.character(as.PCICt(as.POSIXlt(test.values[i]), cal=cal)), test.values[i]) ## Check that as.PCICt.POSIXct works as expected ##checkEquals(as.character(as.PCICt(as.POSIXct(test.values[i]), cal=cal)), test.values[i]) } } ## Check factor case checkEquals(as.PCICt(as.factor(gregorian.not.365), cal="360"), as.PCICt(gregorian.not.365, cal="360")) ## Check that invalid input triggers errors checkException(as.PCICt(cal.360.only, cal="365")) checkException(as.PCICt(cal.360.only, cal="gregorian")) ## Should fail but doesn't; not sure how to hack it other than to pass in month lengths to the so-called "360" funcs. ##checkException(as.PCICt(gregorian.not.365, cal="365")) checkException(as.PCICt(gregorian.not.360, cal="360")) checkException(as.PCICt("your mom", cal="360")) checkException(as.PCICt("your mom", cal="365")) ## Check that NAs are passed through properly checkTrue(is.na(as.PCICt(NA, cal="360"))) checkTrue(is.na(as.PCICt(NA, cal="365"))) ## Check numeric input... checkEquals(as.PCICt(86400, origin="1961-01-01", cal="360"), as.PCICt("1961-01-02", cal="360")) } ## Tests subset operators PCICt.test.subset <- function() { dat <- as.PCICt(test.values, cal="365") dat2 <- dat[2:4] dat3 <- dat dat3[1:2] <- dat[2:3] ## Check that subset operator works as expected checkEquals(as.character(dat[2:4]), as.character(dat)[2:4]) ## Check that subset operator preserves attributes properly checkEquals(attr(dat2, "cal"), attr(dat, "cal")) checkEquals(attr(dat3, "cal"), attr(dat, "cal")) ## Check assignment checkEquals(dat3[1:4], dat[c(2, 3, 3, 4)]) ## Check exception handling dat.360 <- as.PCICt(test.values, cal="360") checkException(dat3[1:3] <- dat.360[2:4]) } ## Tests arithmetic operators (+, -) PCICt.test.operators <- function() { test.365 <- as.PCICt(test.values, cal="365") test.greg <- as.PCICt(test.values, cal="gregorian") ## Check edge cases for each calendar for addition (isn't February a great month?) checkEquals(as.character(as.PCICt("2012-02-28", cal="365") + 86400), "2012-03-01") checkEquals(as.character(as.PCICt("2011-02-28", cal="360") + 2 * 86400), "2011-02-30") checkEquals(as.character(as.PCICt("2012-02-28", cal="gregorian") + 86400), "2012-02-29") ## FIXME: CHECK THAT SUBTRACTION GIVES A DIFFTIME OBJECT checkException(test.365 - test.greg) checkException(test.365 - test.greg) ## Check edge cases for each calendar for subtraction checkEquals(as.numeric(as.PCICt("2012-03-01", cal="365") - as.PCICt("2012-02-28", cal="365"), units="secs"), as.numeric(as.difftime("24:00:00"), units="secs")) checkEquals(as.numeric(as.PCICt("2011-03-01", cal="360") - as.PCICt("2011-02-30", cal="360"), units="secs"), as.numeric(as.difftime("24:00:00"), units="secs")) checkEquals(as.numeric(as.PCICt("2012-03-01", cal="gregorian") - as.PCICt("2012-02-29", cal="gregorian"), units="secs"), as.numeric(as.difftime("24:00:00"), units="secs")) } ## Tests the truncate function PCICt.test.trunc <- function() { date.360 <- as.PCICt("2012-02-28 12:34:56.7", cal="360") date.365 <- as.PCICt("2012-02-28 12:34:56.7", cal="365") date.gregorian <- as.PCICt("2012-02-28 12:34:56.7", cal="gregorian") results <- c("2012-02-28 12:34:56", "2012-02-28 12:34:00", "2012-02-28 12:00:00", "2012-02-28") round.to <- c("secs", "mins", "hours", "days") for(i in 1:length(results)) { checkEquals(as.character(trunc(date.360, round.to[i])), results[i]) checkEquals(as.character(trunc(date.365, round.to[i])), results[i]) checkEquals(as.character(trunc(date.gregorian, round.to[i])), results[i]) } } ## Tests the round function PCICt.test.round <- function() { date.360 <- as.PCICt("2012-02-28 12:34:56.7", cal="360") date.365 <- as.PCICt("2012-02-28 12:34:56.7", cal="365") date.gregorian <- as.PCICt("2012-02-28 12:34:56.7", cal="gregorian") results <- c("2012-02-28 12:34:57", "2012-02-28 12:35:00", "2012-02-28 13:00:00") results.days <- c("2012-02-29", "2012-03-01", "2012-02-29") round.to <- c("secs", "mins", "hours") for(i in 1:length(results)) { checkEquals(as.character(round(date.360, round.to[i])), results[i]) checkEquals(as.character(round(date.365, round.to[i])), results[i]) checkEquals(as.character(round(date.gregorian, round.to[i])), results[i]) } checkEquals(as.character(round(date.360, "days")), results.days[1]) checkEquals(as.character(round(date.365, "days")), results.days[2]) checkEquals(as.character(round(date.gregorian, "days")), results.days[3]) } ## Tests the cut function PCICt.test.cut <- function() { } PCICt.test.summary <- function() { } PCICt.test.format <- function() { } PCICt.test.as.POSIXlt <- function() { } PCICt.test.as.POSIXct <- function() { } PCICt.test.julian <- function() { } PCICt.test.range <- function() { } PCICt.test.pretty <- function() { } PCICt.test.c <- function() { } PCICt.test.seq <- function() { ## Check that sequences work as expected checkEquals(seq(as.PCICt("2011-02-30", cal="360"), as.PCICt("2012-04-01 00:10:00", cal="360"), by="years"), as.PCICt(c("2011-02-30", "2012-02-30"), cal="360")) checkEquals(seq(as.PCICt("2011-02-28", cal="365"), as.PCICt("2012-04-01 00:10:00", cal="365"), by="years"), as.PCICt(c("2011-02-28", "2012-02-28"), cal="365")) checkEquals(seq(as.PCICt("2011-02-28", cal="gregorian"), as.PCICt("2012-04-01 00:10:00", cal="gregorian"), by="years"), as.PCICt(c("2011-02-28", "2012-02-28"), cal="gregorian")) checkEquals(seq(as.PCICt("2011-02-30", cal="360"), as.PCICt("2011-03-03 00:10:00", cal="360"), by="days"), as.PCICt(c("2011-02-30", "2011-03-01", "2011-03-02", "2011-03-03"), cal="360")) checkEquals(seq(as.PCICt("2012-02-28", cal="365"), as.PCICt("2012-03-03 00:10:00", cal="365"), by="days"), as.PCICt(c("2012-02-28", "2012-03-01", "2012-03-02", "2012-03-03"), cal="365")) checkEquals(seq(as.PCICt("2012-02-28", cal="gregorian"), as.PCICt("2012-03-03 00:10:00", cal="gregorian"), by="days"), as.PCICt(c("2012-02-28", "2012-02-29", "2012-03-01", "2012-03-02", "2012-03-03"), cal="gregorian")) } PCICt/src/0000755000175100001440000000000012162700306011756 5ustar hornikusersPCICt/src/strptime_360.h0000644000175100001440000007423613265121453014407 0ustar hornikusers/* 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 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); } } PCICt/src/datetime_360.c0000644000175100001440000007062413265121453014324 0ustar hornikusers/* * 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; 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); setAttrib(ans, install("tzone"), mkString("GMT")); UNPROTECT(4); 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); 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; sprintf(p2, "%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; 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); setAttrib(ans, install("tzone"), mkString("GMT")); UNPROTECT(3); return ans; } SEXP do_D2POSIXlt_360(SEXP data) { SEXP x, ans, ansnames, klass; 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); setAttrib(ans, install("tzone"), mkString("UTC")); UNPROTECT(4); 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_init_mylib(DllInfo* info) { R_CallMethodDef callMethods[] = { {"do_asPOSIXlt_360", (DL_FUNC) &do_asPOSIXlt_360, 1 }, {"do_asPOSIXct_360", (DL_FUNC) &do_asPOSIXct_360, 1 }, {"do_formatPOSIXlt_360", (DL_FUNC) &do_formatPOSIXlt_360, 2 }, {"do_strptime_360", (DL_FUNC) &do_strptime_360, 2 }, {"do_D2POSIXlt_360", (DL_FUNC) &do_D2POSIXlt_360, 1 }, {"do_POSIXlt2D_360", (DL_FUNC) &do_POSIXlt2D_360, 1 }, { NULL, NULL, 0 } }; R_registerRoutines(info, NULL, callMethods, NULL, NULL); } void R_unload_mylib(DllInfo* info) { } PCICt/NAMESPACE0000644000175100001440000000200713265121354012412 0ustar hornikusersimport(graphics) import(methods) useDynLib(PCICt) 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(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) PCICt/CHANGELOG0000644000175100001440000000143312162677737012427 0ustar hornikusers0.5-4: Fix test so Windows build works. 0.5-3: License change, proper credit to authors of code used as a base for PCICt. 0.5-2: RESULTS CHANGE: Default gregorian calendar is proleptic; corrections applied are invalid. "Correction" code removed. Minor change: Add checking for calendar to operators. 0.5-1: API CHANGE: as.PCICt.numeric's argument order has changed RESULTS CHANGE: Modified code to make 360-day calendars have 12 30-day months. 0.4-1: Add support for proleptic gregorian calendar. 0.3-2: Fix off-by-one with Julian days. 0.3-1: Add min.PCICt and max.PCICt. 0.2-2: Actually export as.PCICt.POSIXct in the namespace. Whoops. 0.2-1: Cleaned up comments in code, added as.PCICt.POSIXct, added documentation for it, added more examples. 0.1-2: Initial version. PCICt/R/0000755000175100001440000000000012022237022011363 5ustar hornikusersPCICt/R/PCICt.R0000644000175100001440000006157312022170341012424 0ustar hornikusersorigin.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") } 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) } 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)) } `+.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")) } `-.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")) } 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) } rep.PCICt <- function(x, ...) { y <- rep(unclass(x), ...) .PCICt(y, cal=attr(x, "cal")) } mean.PCICt <- function(x, ...) { .PCICt(mean(unclass(x), ...), attr(x, "cal")) } min.PCICt <- function(x, ...) { res <- min(unclass(x), ...) return(copy.atts.PCICt(x, res)) } max.PCICt <- function(x, ...) { res <- max(unclass(x), ...) return(copy.atts.PCICt(x, res)) } 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 } } 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)) } 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) } 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"))) } `[.PCICt` <- function(x, ...) { val <- NextMethod("[") val <- copy.atts.PCICt(x, val) class(val) <- class(x) val } `[<-.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 } as.PCICt <- function(x, cal, ...) { if(missing(cal)) stop("Can't create a PCICt with no calendar type") UseMethod("as.PCICt") } as.character.PCICt <- function(x, ...) { format.PCICt(x, ...) } 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)) } 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 } 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)) } } 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) } strptime.360 <- function(x, format) { .Call("do_strptime_360", x, format) } 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) names(y) <- names(x$year) y } as.POSIXct.POSIXlt.360 <- function(x) { .Call("do_asPOSIXct_360", x, format) } as.POSIXlt.POSIXct.360 <- function(x) { .Call("do_asPOSIXlt_360", x, format) } 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)))) } 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) } 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)) } } 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 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)) } } 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))) } 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 } diff.PCICt <- function (x, lag = 1L, differences = 1L, ...) { class(x) <- c("POSIXct", "POSIXt") diff(x, lag, differences, ...) } is.numeric.PCICt <- function(x) FALSE 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) } 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")) } 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, ...) } 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]]) } PCICt/MD50000644000175100001440000000111413265135314011502 0ustar hornikusersfe80639f26e20e765caf96d25a09917a *CHANGELOG 587748cfc380b7ea40050ef2d622fc80 *DESCRIPTION 948456055fe9ce189e683fe492ff2f5e *NAMESPACE 337d23343136db94abd0ba7d4acaed32 *R/PCICt.R e40937e5c74f4c2b49becaab9e82a108 *man/Ops.PCICt.Rd 1b04c8609ceb0299871d6f090a216bbc *man/PCICt.Rd 6ecc1c6cc8977a79dc41b2a2415c4105 *man/as.PCICt.Rd e893dc76cd9a99c59ee122f6283f28f1 *man/round.Rd 368915f52c8223b0f1593b796f1ccde5 *src/datetime_360.c 8665e612e7336a8f508d83e813abbe70 *src/strptime_360.h 1b285569312a34948d25b8f728307486 *tests/bootstrap.R 2a882b66680d35f6a5d3d02c32ead042 *tests/test_functions.R PCICt/DESCRIPTION0000644000175100001440000000132413265135314012703 0ustar hornikusersPackage: PCICt Version: 0.5-4.1 Date: 2013-06-26 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: David Bronaugh 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 Packaged: 2018-04-16 13:20:43 UTC; hornik NeedsCompilation: yes Repository: CRAN Date/Publication: 2018-04-16 15:01:32 UTC PCICt/man/0000755000175100001440000000000012162700306011742 5ustar hornikusersPCICt/man/as.PCICt.Rd0000644000175100001440000000677012022170171013543 0ustar hornikusers\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} \title{PCICt} \description{ These functions convert between PCICt objects and other types of data. } \usage{ \method{as}{PCICt}(x, cal, \dots) .PCICt(x, cal) \method{as.PCICt}{numeric}(x, cal, origin, \dots) \method{as.PCICt}{default}(x, cal, format, \dots) \method{as.PCICt}{POSIXlt}(x, cal, \dots) \method{as.PCICt}{POSIXct}(x, cal, \dots) \method{as.POSIXct}{PCICt}(x, tz="", \dots) \method{as.POSIXlt}{PCICt}(x, tz="", \dots) \method{as.character}{PCICt}(x, ...) } \arguments{ \item{x}{the input data.} \item{cal}{the calendar type.} \item{origin}{the origin for a numeric time.} \item{tz}{the time zone to put the data in.} \item{format}{the format to parse the date using.} \item{...}{any additional arguments passed on.} } \details{ as.PCICt converts the x argument, where x is of type POSIXlt, POSIXct, or character, to a PCICt object with the given calendar type. Calendar types include 360 day calendars("360_day", "360"), 365 day calendars ("365_day", "365", "noleap"), and Gregorian calendars ("gregorian", "proleptic_gregorian"). When converting a character object, one can also specify the format with fmt=, which uses a format documented in the help page for strptime. .PCICt converts numeric objects into PCICt objects, using x as seconds since 1970-01-01 and applying the supplied calendar to the data. as.PCICt.numeric converts numeric objects into PCICt objects, using \code{x} as seconds since the origin. \code{origin} can be either a character or a PCICt object. as.POSIXct.PCICt and as.POSIXlt.PCICt convert PCICt objects into POSIXct or POSIXlt objects, respectively. With POSIXct objects, this may result in apparent gaps in the timeseries, and the transformation will not be trivially reversible. See the example below for how to transition between PCICt and POSIXct. as.character.PCICt converts a PCICt object to a character string representation of that object. as.PCICt.default, as.PCICt.POSIXct, and as.PCICt.POSIXlt are helpers which are called by as.PCICt. Normally you will not need to call them directly. } \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. } \examples{ ## Convert these strings to PCICt objects. x <- as.PCICt(c("1961-09-02", "1963-02-01"), cal="360_day") ## Convert these strings to POSIXlt objects, then coerce them into PCICt objects. y <- as.POSIXlt(c("1961-09-02", "1963-02-01")) x <- as.PCICt(y, cal="360_day") ## Convert a string to PCICt using a format string. q <- as.PCICt("03292001", cal="365_day", format="\%m\%d\%Y") ## This will cause a parsing error. \dontrun{bad.r <- as.PCICt("moo", cal="365_day")} ## Convert a POSIXct to PCICt 360-day foo <- as.POSIXct("2011-04-01") bar <- as.PCICt(as.character(foo), cal="360_day") ## Test whether the result is the same baz <- as.PCICt("2011-04-01", cal="360_day") bar == baz ## Convert a sequence of days plus an origin to PCICt (as seen in NetCDF files) cal <- "365_day" origin <- "1968-01-01" seconds.per.day <- 86400 ts.dat.days <- 0:100 origin.pcict <- as.PCICt(origin, cal) ts.dat.pcict <- origin.pcict + (ts.dat.days * seconds.per.day) } \seealso{ \code{\link{as.POSIXlt}}, \code{\link{as.POSIXct}}, \code{\link{strptime}} } \keyword{ts}PCICt/man/Ops.PCICt.Rd0000644000175100001440000000114511642721723013704 0ustar hornikusers\name{Ops.PCICt} \alias{Ops.PCICt} \alias{+.PCICt} \alias{-.PCICt} \alias{[.PCICt} \alias{[<-.PCICt} \title{Ops.PCICt} \description{ These functions implement subtraction, addition, indexing, and index assignment operations as in POSIXct. } \value{ A PCICt object with the given operations performed. } \examples{ ## Create a list of PCICt of length 2 with a 365-day calendar x <- as.PCICt(c("1961-09-02", "1963-02-01"), cal="365_day") ## Look at the difference between the two elements of x y <- x[1] - x[2] ## Change the first element of x x[1] <- as.PCICt("1962-09-02", cal="365_day") } \keyword{ts}PCICt/man/round.Rd0000644000175100001440000000153711750574776013414 0ustar hornikusers\name{round.PCICt} \alias{round.PCICt} \title{round.PCICt} \description{ Round PCICt objects to the nearest second/minute/hour/day } \usage{ \method{round}{PCICt}(x, digits = c("secs", "mins", "hours", "days")) } \arguments{ \item{x}{Dates to be rounded.} \item{digits}{Unit to round the dates to.} } \details{ round.PCICt rounds the dates in the \code{x} argument to the nearest second/minute/hour/day, as specified by the poorly named \code{digits} argument. } \value{ The dates in \code{x}, rounded to the nearest second/minute/hour/day. } \examples{ ## Convert strings to PCICt objects, on a 360 day calendar x <- as.PCICt(c("1961-02-30 12:00:00", "1962-03-24 12:34:56"), cal="360") ## Round them to the nearest hour x.hour <- round(x, "hours") ## Round them to the nearest day x.day <- round(x, "days") } \seealso{ \code{\link{trunc}} }PCICt/man/PCICt.Rd0000644000175100001440000000543511650404526013150 0ustar hornikusers\name{PCICt} \alias{PCICt-package} \docType{package} \title{PCICt, a POSIXct work-alike for 360- and 365-day calendars} \description{ This package implements a work-alike to R's POSIXct class which implements 360- and 365-day calendars in addition to the gregorian calendar. } \details{ Many global climate models (GCMs) and regional climate models (RCMs) are run using an idealized and simplified calendar which only includes 365 days or 360 days per year. When trying to do seasonal or monthly analysis on a set of models which use different calendar types, analyses may not be comparable unless one can normalize the calendars and the times which are represented therin. Thing get even more difficult when trying to compare model output with observations data which is located in a particular time on the Gregorian calendar. The PCICt package attempts to solve this problem by creating a new time type, PCICt, which inherits from the POSIXt type. All of the functionality provided by POSIXt is also provided by PCICt, however PCICt does the work of normalizing the calendars and making points in time on seperate calendars cross comparable. 365-day calendars are implemented using a 365-day non-leap year from a Gregorian calendar. 360-day calendars are not implemented as 12 equal months of 30 days. They are implemented as 12 months of the following lengths, in days, with the first month being January: 30, 28, 31, 30, 30, 30, 30, 31, 30, 30, 30, 30. This was a decision to ease implementation. To map a 365_day calendar to Gregorian, PCICt simply drops February 29 from leap years. To map a 360_day calendar to Gregorian, PCICt attempts to remap the days such that the five lost days are distributed as equally as possible across the seasons (winter loses two days while, spring/summer/fall each lose one). There are a few problems with this implementation. As noted above, 360-day calendars do not use equal months, which may cause problems in certain situations. Another problem originates from within R itself. Many functions in R strip attributes from data. If this happens to a PCICt object, it cannot be coerced back into a PCICt, as it is lacking the calendar attribute. This causes problems with several internal functions, like mean. PCICt includes a wrapper for mean. You will probably run into these problems. When you do, please use the wrapper for mean as a template for your wrapper. This package may be modified substantially in future to solve these problems. } \references{ \url{http://www.pacificclimate.org} } \seealso{ \code{\link{as.PCICt}} } \keyword{climate} \keyword{ts} \keyword{calendar} \keyword{date} \keyword{time} \keyword{chron} \keyword{utilities}