Nothing
# This R package 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.
#
# This R package 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 this R package; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
## 2023-11-27
## GNB: reworked the Japan's holidays as they all were set to fixed dates,
## and also to reflect changes in recent decades.
################################################################################
# FUNCTION: DESCRIPTION:
# ... Holiday Dates
################################################################################
## 2023-12-07 GNB: new
format..sdate <- function(x, format = "-", ...) {
## TODO: think it over
if(format == "-")
paste(substr(x, 1, 4), substr(x, 5, 6), substr(x, 7, 8), sep = "-")
else if(format == "")
paste(substr(x, 1, 4), substr(x, 5, 6), substr(x, 7, 8), sep = "")
else # TODO: needs more here
format.default(x, format = format, ...)
}
Septuagesima =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, -63)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
Quinquagesima =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, -49)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
AshWednesday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, -46)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
PalmSunday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, -7)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
GoodFriday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, -2)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
EasterSunday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
EasterMonday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 1)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
RogationSunday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 35)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
Ascension =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 39)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
Pentecost =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 49)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
## GNB: WhitMonday
PentecostMonday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 50)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
TrinitySunday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 56)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
CorpusChristi =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 60)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
# ------------------------------------------------------------------------------
ChristTheKing =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .on.or.after(year, 11, 20, 0)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
Advent1st =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .on.or.after(year, 11, 27, 0)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
Advent2nd =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .on.or.after(year, 12, 4, 0)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
Advent3rd =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .on.or.after(year, 12, 11, 0)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
Advent4th =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .on.or.after(year, 12, 18, 0)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
ChristmasEve =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1224
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
ChristmasDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1225
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
BoxingDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1226
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
# ------------------------------------------------------------------------------
SolemnityOfMary =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0101
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
Epiphany =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0106
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
PresentationOfLord =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0202
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
Annunciation =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0325
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
TransfigurationOfLord =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0806
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
AssumptionOfMary =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0815
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
BirthOfVirginMary =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0908
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
CelebrationOfHolyCross =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0914
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
MassOfArchangels =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0929
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
AllSaints =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1101
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
AllSouls =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1102
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
# ------------------------------------------------------------------------------
NewYearsDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0101
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
LaborDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0501
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
# ------------------------------------------------------------------------------
CHBerchtoldsDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0102
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
CHSechselaeuten =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = NULL
for (y in year) {
theDate = .nth.of.nday(y, 4, 1, 3)
if (as.character(theDate) == as.character(Easter(y, +1))) {
theDate = .nth.of.nday(y, 4, 1, 4)
}
ans = c(ans, theDate) # this changes the class from .sdate to numeric,
# hence as.character() below
}
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
CHAscension =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 39)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
CHConfederationDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0801
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
CHKnabenschiessen =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 9, 1, 2)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
# ------------------------------------------------------------------------------
## GNB: Early May bank holiday
## GNB: renaming to the proper name; leaving for now 'GBMayDay' for compatibility
##
## the code in holidaysLONDON for y > 1978 was:
## if (y == 1995 || y == 2020) {
## ## Was moved to May 8 to celebrate VE Day's 75th/50th anniversary
## dts <- paste0(y, "-05-08")
## holidays <- c(holidays, dts)
## } else {
## lon <- timeDate(.on.or.after(y, 5, 1, 1), zone = "London",
## FinCenter = "Europe/London")
## holidays <- c(holidays, as.character(lon))
## }
GBMayDay <-
GBEarlyMayBankHoliday <-
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
## TODO: y < 1978 - NA or empty
## if (y >= 1978)
## # First Monday of May became a bank holiday
if(flag <- isTRUE(na_drop))
year <- year[year >= 1978]
ans = .nth.of.nday(year, 5, 1, 1)
## special: moved to May 8 to celebrate VE Day's 50th/75th anniversary
ind <- year %in% c(1995, 2020)
if(any(ind))
ans[ind] <- 10000 * year[ind] + 0508
if(!flag && isFALSE(na_drop))
ans[year < 1978] <- NA
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
## YC: Note GBBankHoliday returns Spring Bank Holiday
## GNB: renaming to a more common name; leaving for now 'GBBankHoliday' for compatibility
##
GBBankHoliday <-
GBSpringBankHoliday <-
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
## introduced in 1871, first on Whit Monday
if((flag <- isTRUE(na_drop)) && any(year < 1871))
year <- year[year >= 1871]
ans = .last.of.nday(year, 5, 31, 1)
## Whit Monday, which is exactly 50 days after Easter
if(any(year <= 1964)) {
## using arg 'format' as the default for timeDate objects is "%Y-%m-%d"
ans[year <= 1964] <- as.numeric(format(Easter(year[year <= 1964], 50),
format = "%Y%m%d"))
}
## moved to be the day before XXX/Diamond/Platinum Jubilee bank holiday
ind <- year %in% c(2002, 2012, 2022)
if(any(ind)) {
ans[year == 2002] <- 20020603
ans[year == 2012] <- 20120604 # Last Monday in May holiday moved to June 4, and
# Queen's Diamond Jubilee on June 5
ans[year == 2022] <- 20220602 # Thursday
}
if(!flag && isFALSE(na_drop))
ans[year < 1871] <- NA
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
## GNB: added handling of historical dates before 1971,
## including 1965-1970 for which many sources have it wrong for 1968, 1969
##
## Last Monday in August replaces first Monday in August as Summer BH.
##
## 2023-12-04 GNB:
##
## Between 1965-1970 there was a trial period of moving the Summer BH to 'the
## end of the month', without formal definition (see wikipedia page). A
## royal proclamation was issued each year for the exact dates. It seems
## that they used the Monday after the weekend containing the last
## Saturday in August. in 1968 and 1969 Summer Bank Holiday is in the
## beginning of Sep:
## see https://api.parliament.uk/historic-hansard/written-answers/1965/jun/03/bank-holidays-1967-and-1968
## https://family-law.co.uk/significance-bank-holidays/
## 2 Sep 1968
## 1 Sep 1969
## TODO: add the above! But need to check reverse dependencies when doing that!
##
## The formal definition as "Last Monday in August" is from the 1971 Act
## but the difference for 1965-1970 isa only for 1968, 1969 as noted above
GBSummerBankHoliday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
## established in 1871 as the 1st Monday in August, so
## ans[year < 1871] <- NA or empty :TODO:
## didn't exist before 1871
if((flag <- isTRUE(na_drop)) && any(year < 1871))
year <- year[year >= 1871]
ans = .last.of.nday(year, 8, 31, 1) # year >= 1965
if(any(year <= 1970)) {
## Summer BH on First Monday in August
ans[year <= 1964] <- .on.or.after(year[year <= 1964], 8, 1, 1)
## correct for 1968 & 1969, see comments above
ans[year == 1968] <- 19680902
ans[year == 1969] <- 19690901
}
if(!flag && isFALSE(na_drop))
ans[year < 1871] <- NA
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
## added by GNB
## TODO: it ignores, silently, the argument, not good?
GBMilleniumDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
.Deprecated("Use specialHolidayGB(1999)")
ans = 19991231
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
.gb_oneoff_holidays <- c(
"GBRoyalWeddingDay1981" , "1981-07-29", # Royal wedding
"GBMillenumDay" , "1999-12-31", # UK millenum day
"GBQueensGoldenJubileeDay" , "2002-06-04", # Spring BH moved to June 3,
# and Queen's Jubilee on June 4
"GBRoyalWeddingDay2011" , "2011-04-29", # Royal wedding
"GBQueensDiamondJubilee" , "2012-06-05", # Early May BH moved to June 4
# and Queen's Diamond Jubilee on June 5
# Spring BH moved to June 2
"GBQueensPlatinumJubileeDay" , "2022-06-03", # Friday, Platinum Jubilee BH
"GBQueensFuneralDay" , "2022-09-19", # BH, State Funeral Queen Elizabeth II
"GBKingCharlesIIICoronationDay", "2023-05-08" # BH, coronation of King Charles III
)
## .gb_oneoff_BH <- matrix(.gb_oneoff_holidays, ncol = 2, byrow = TRUE)
## .gb_years <- as.integer(substr(.gb_oneoff_BH[ , 2], 1, 4))
## .unique_gb_years <- unique(.gb_years)
.GByears_with_oneoff <-
c(1981, 1999, 2002, 2011, 2012, 2022, 2023)
specialHolidayGB <-
function(year = getRmetricsOptions("currentYear"), value = "timeDate", named = FALSE, ...) {
## TODO: option to return names for the holidays;
## maybe it is better to just provide separate function for that
##
## TODO: No, it doesn't make sense to return NA's. In some years there may be
## more than one special holiday (2022 in GB), so alignment cannot be guaranteed.
## Hence:
## 1. use sort and unique on year as in the holidayXXX functions
## 2. remove the irrelevant arguments
## 3. rename this function, e.g. to holidaySpecialGB
##
## here value = "" doesn't make sense, treat it the same as FALSE
year <- year[year %in% .GByears_with_oneoff]
ans <- character(0)
## TODO: need more elegant solution but this should do.
## Bear in mind that there may be more than one special BH in a year!
if(named) {
## same as for 'else' with names
for(y in year) {
ans <- list(ans,
if (y == 1981) # Royal wedding was a public holiday
c("GBRoyalWeddingDay1981" = "1981-07-29")
else if (y == 1999) # UK millenum day
c(GBMillenumDay = "1999-12-31")
else if (y == 2002) # Last Monday in May holiday moved to June
c(GBQueensGoldenJubileeDay = "2002-06-04") # 3, and Queen's Jubilee on June 4
else if (y == 2011) # Royal wedding declared a public holiday
c(GBRoyalWeddingDay2011 = "2011-04-29")
else if (y == 2012)
c(GBQueensDiamondJubilee = "2012-06-05") # Last Monday in May holiday moved to June 4, and
# Queen's Diamond Jubilee on June 5
else if (y == 2022)
# Last Monday in May (i.e., Spring Bank Holiday) moved to June 2
# Unique Bank holidays: Queen's Diamond Jubilee.
# State Funeral of Queen Elizabeth II
c(# paste0(y, "-06-02"), # Thursday, Spring bank holiday
GBQueensPlatinumJubileeDay = "2022-06-03", # Friday, Platinum Jubilee bank holiday
GBQueensFuneralDay = "2022-09-19") # BH for the State Funeral of Queen Elizabeth II
else if (y == 2023) # Bank holiday for the coronation of King Charles III
c(GBKingCharlesIIICoronationDay = "2023-05-08")
else
stop("should not reach this branch of the program")
)
}
} else {
for(y in year) {
ans <- list(ans,
if (y == 1981) # Royal wedding was a public holiday
"1981-07-29"
else if (y == 1999) # UK millenum day
"1999-12-31"
else if (y == 2002) # Last Monday in May holiday moved to June
"2002-06-04" # 3, and Queen's Jubilee on June 4
else if (y == 2011) # Royal wedding declared a public holiday
"2011-04-29"
else if (y == 2012)
"2012-06-05" # Last Monday in May holiday moved to June 4, and
# Queen's Diamond Jubilee on June 5
else if (y == 2022)
# Last Monday in May (i.e., Spring Bank Holiday) moved to June 2
# Unique Bank holidays: Queen's Diamond Jubilee.
# State Funeral of Queen Elizabeth II
c(# paste0(y, "-06-02"), # Thursday, Spring bank holiday
"2022-06-03", # Friday, Platinum Jubilee bank holiday
"2022-09-19") # BH for the State Funeral of Queen Elizabeth II
else if (y == 2023) # Bank holiday for the coronation of King Charles III
"2023-05-08"
else
stop("should not reach this branch of the program")
)
}
}
ans <- sort(unlist(ans))
if(value == "timeDate") timeDate(ans, format = "%Y-%m-%d") else ans
}
# ------------------------------------------------------------------------------
DEAscension =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 39)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
DECorpusChristi =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 60)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
DEGermanUnity =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1003
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
DEChristmasEve =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1224
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
DENewYearsEve =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1231
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
# ------------------------------------------------------------------------------
FRFetDeLaVictoire1945 =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0508
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
FRAscension =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, 39)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
FRBastilleDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0714
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
FRAssumptionVirginMary =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0815
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
FRAllSaints =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1101
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
FRArmisticeDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1111
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
# ------------------------------------------------------------------------------
ITEpiphany =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0106
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
ITLiberationDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0425
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
ITAssumptionOfVirginMary =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0815
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
ITAllSaints =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1101
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
ITStAmrose =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1207
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
ITImmaculateConception =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1208
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
# ------------------------------------------------------------------------------
USNewYearsDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0101
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
USInaugurationDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0120
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
USMLKingsBirthday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 1, 1, 3)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
USLincolnsBirthday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0212
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
USWashingtonsBirthday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year * 10000 + 222
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
USMemorialDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .last.of.nday(year, 5, 31, 1)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
USIndependenceDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0704
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
USLaborDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 9, 1, 1)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
USColumbusDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 10, 1, 2)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
USElectionDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .on.or.after(year, 11, 2, 2)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
USVeteransDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1111
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
USThanksgivingDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 11, 4, 4)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
USChristmasDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1225
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
USCPulaskisBirthday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 3, 1, 1)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
USGoodFriday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = Easter(year, -2)
if(value == "timeDate") timeDate(as.character(ans)) else as.character(ans, ...)
}
USPresidentsDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 2, 1, 3)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
USDecorationMemorialDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0530
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
## Fixes issue #6755 by Ian E (ene100)
## Juneteenth introduced as National US holiday in 2021;
## holiday on NYSE from 2022
## https://www.sec.gov/rules/sro/nyse/2021/34-93183.pdf (see p. 2 for definition)
USJuneteenthNationalIndependenceDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
## didn't exist before 2021
if(flag <- isTRUE(na_drop))
year <- year[year >= 2021]
ans <- year*10000 + 0619
if(!flag && isFALSE(na_drop))
ans[year < 2021] <- NA
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
# ------------------------------------------------------------------------------
CAVictoriaDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .on.or.before(year, 5, 24, 1)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
CAFamilyDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...)
{ # Description:
# Adds the new Family Day
# Note:
# Check ...
# www.sbhlawyers.com/media/ELD%20Oct%2019%202007%20Public%20Holidays%20and%20Family%20Day.pdf
# Family Day will fall on the third Monday of
# every February, beginning in 2008.
# Family Day:
## rewritten by GNB
## doesn't exist before 2008
if(flag <- isTRUE(na_drop))
year <- year[year >= 2008]
ans <- .nth.of.nday(year, 2, 1, 3)
if(!flag && isFALSE(na_drop))
ans[year < 2008] <- NA
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
CACanadaDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0701
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
CACivicProvincialHoliday =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 8, 1, 1)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
CALabourDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 9, 1, 1)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
CAThanksgivingDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 10, 1, 2)
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
CaRemembranceDay =
function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1111
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
# ------------------------------------------------------------------------------
# Japan
# ---------------------------------------------------------------------------- #
JPVernalEquinox <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
# Author:
# Parlamis Franklin wrote:
# It's me again, with Japanese calendar minutiae I'm sure you've all
# been dying to brush up on. The fCalendar functions don't include
# the Japanese Vernal Equinox holiday. this is perhaps because there
# is no easy way to calculate it. at any rate, here's a function I
# wrote to fill the gap.
# Notes:
# Origin and End Date data from
# http://aa.usno.navy.mil/data/docs/EarthSeasons.html
# The function Vernal.Equinox delivers correct values at the
# endpoints of the above data. There may be minor variances
# (+/- a few minutes) in the intermediate values, because the
# function linearly approximates a phenomenon that is apparently
# nonlinear in recorded time.
Equinox.Origin <- timeCalendar(1992, 3, 20, 8, 48, 0, FinCenter = "GMT")
Data.EndDate <- timeCalendar(2020, 3, 20, 3, 49, 0, FinCenter = "GMT")
Total.Seconds <- as.numeric(Data.EndDate-Equinox.Origin)*24*60*60
Mean.Annual.Seconds <- Total.Seconds / (atoms(Data.EndDate)$Y -
atoms(Equinox.Origin)$Y)
Vernal.Equinox <- function(year)
{
Equinox.Origin +
unclass((year-atoms(Equinox.Origin)$Y)*Mean.Annual.Seconds)
}
# Nota bene: JP Vernal Equinox is celebrated when the equinox
# occurs in the Japanese time zone (see, e.g., 2006, where GMT
# Vernal Equinox is on 20 March, but Japanese Equinox holiday is
# 21 March)
# Return Value:
trunc(timeDate(as.character(Vernal.Equinox(year)), FinCenter = "Tokyo"))
}
JPNewYearsDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0101
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
JPGantan <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0101
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
JPBankHolidayJan2 <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0102
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
JPBankHolidayJan3 <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0103
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
## GNB - fixed to give 2nd Monday of January
## Also, combined JPSeijinNoHi and JPComingOfAgeDay, since they seem to
## be the same thing.
JPSeijinNoHi <-
JPComingOfAgeDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = .nth.of.nday(year, 1, 1, 2) # 2023-11-27 was: year*10000 + 0115
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
JPKenkokuKinenNoHi <-
JPNatFoundationDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans <- year * 10000 + 0211
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
JPMidoriNoHi <-
JPGreeneryDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans <- year*10000 + 0504 # year >= 2007
if(any(year < 2007)) {
ans[year < 2007] <- year*10000 + 0429
## ans[year < 1989] <- NA # but it was Emperor's Birthday back then
}
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
## https://en.wikipedia.org/wiki/Golden_Week_(Japan)
## Citizen's Holiday (国民の休日, Kokumin no Kyūjitsu) is a generic term for any official
## holiday. Until 2006, 4 May was an unnamed but official holiday because of a rule that
## converts any day between two holidays into a new holiday.
JPKokuminNoKyujitu <-
JPNationHoliday <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0504
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
JPKenpouKinenBi <-
JPConstitutionDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0503
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
JPKodomoNoHi <-
JPChildrensDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0505
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
## https://en.wikipedia.org/wiki/Marine_Day
## 2023 date: July 17
## 2022 date: July 18
## 2024 date: July 15
## 2025 date: July 21
JPUmiNoHi <-
JPMarineDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
## GNB was: ans = year*10000 + 0720
if(flag <- isTRUE(na_drop))
year <- year[year >= 1996]
ans = .nth.of.nday(year, 7, 1, 3) # from 2003
ans[year < 2003] <- year*10000 + 0720
if(!flag && isFALSE(na_drop))
ans[year < 1996] <- NA
if(any(year %in% c(2020, 2021))) {
ans[year == 2020] <- 2020 * 10000 + 0723 # Olympics
ans[year == 2021] <- 2021 * 10000 + 0722
}
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
## 2023-11-27 - deprecated;
JPKeirouNOhi <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
.Deprecated("JPKeirouNoHi")
JPKeirouNoHi(year)
}
JPKeirouNoHi <-
JPRespectForTheAgedDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
## GNB was: ans = year*10000 + 0915
## https://en.wikipedia.org/wiki/Respect_for_the_Aged_Day
if(flag <- isTRUE(na_drop))
year <- year[year >= 1966]
ans = .nth.of.nday(year, 9, 1, 3)
if(any(year < 2003)) {
ans[year < 2003] = year*10000 + 0915
if(!flag && isFALSE(na_drop))
ans[year < 1966] <- NA
}
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
## GNB: TODO: this cannot be constant, see above for the vernal equinox.
##
## for now, changing it to 23 Sep and correct for known dates when it is on other dates,
## usually 22 Sep https://en.wikipedia.org/wiki/Autumnal_Equinox_Day
JPShuubunNoHi <-
JPAutumnalEquinox <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans <- year * 10000 + 0923 # was + 0924 but this is rare
on22nd <- c(2016, 2024, 2028) # incomplete; after 2024 predicted
ans[year %in% on22nd] <- year[year %in% on22nd] * 10000 + 0922
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
JPTaiikuNoHi <-
JPHealthandSportsDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
## updated and rewritten by GNB
## was: ans = year*10000 + 1010
## https://en.wikipedia.org/wiki/Sports_Day_(Japan)
ans = .nth.of.nday(year, 10, 1, 2)
ans[year == 2021] <- 2021 * 10000 + 0723 # Olympics openning
ans[year == 2020] <- 2020 * 10000 + 0724 # Olympics cancelled but holiday stayed
if(length(tmp_flag <- 1966 <= year & year <= 1999))
ans[tmp_flag] <- year[tmp_flag] * 10000 + 1010
if(value == "timeDate") timeDate(ans) else format..sdate(ans, ...)
}
JPBunkaNoHi <-
JPNationalCultureDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1103
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
JPKinrouKanshaNoHi <-
JPThanksgivingDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
## https://en.wikipedia.org/wiki/Labor_Thanksgiving_Day
ans = year*10000 + 1123 ## TODO: if on Sunday move to Monday !!!
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
## GNB: none in 2019;
## 2020+ - 23 Feb (Naruhito), but seems that if its on Sunday (on the weekend?), it is moved to Monday.
## for 2025 - 24 Feb,
## according to https://www.officeholidays.com/holidays/japan/the-emperors-birthday
## 1989-2018 23 Dec (Akihito)
## 1926(7?)-1988 29 April (stil public holiday - Greenery Day since 1989, Showa day since 2007.
## https://en.wikipedia.org/wiki/The_Emperor%27s_Birthday
JPTennouTanjyouBi <-
JPEmperorsBirthday <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
if(flag <- isTRUE(na_drop)) {
year <- year[year >= 1927] # don't know what it was before 1927
year <- year[year != 2019] # due to abdication this holiday was cancelled in 2019
}
ans = year*10000 + 0223 # Naruhito
if(any(year < 2020)){
if(!flag && isFALSE(na_drop)) {
ans[year == 2019] <- NA
ans[year <= 1927] <- NA
}
flag_1989to2018 <- 1989 <= year & year <= 2018
flag_1927to1988 <- 1927 <= year & year <= 1988
if(length(flag_1989to2018))
ans[flag_1989to2018] <- year[flag_1989to2018] * 10000 + 1223 # Akihito
if(length(flag_1927to1988))
ans[flag_1927to1988] <- year[flag_1927to1988] * 10000 + 0429 # Showa
## TODO: before 1927 ?
}
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
## TODO: check
JPBankHolidayDec31 <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 1231
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
## GNB new 2023-11-27 its absence reported by Sylvie Lachaud
## Moutain day 11/08/2023 : is it missing in your list ?
## https://en.wikipedia.org/wiki/Mountain_Day#Mountain_Day_in_Japan
JPMountainDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
## didn't exist before 2016
if(flag <- isTRUE(na_drop))
year <- year[year >= 2016]
ans <- year * 10000 + 0811
if(!flag && isFALSE(na_drop))
ans[year < 2016] <- NA
ans[year == 2020] <- 2020*10000 + 0810 # Olympics openning (cancelled)
ans[year == 2021] <- 2021*10000 + 0809 # Olympics openning
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
## Other holidays
InternationalWomensDay <- function(year = getRmetricsOptions("currentYear"), value = "timeDate", na_drop = TRUE, ...) {
ans = year*10000 + 0308
if(value == "timeDate") timeDate(as.character(ans)) else format..sdate(ans, ...)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.