R/calendar.R

In gfunk0704/RcppQuantitativeFinance: What the Package Does in One 'Title Case' Line

setClass(
    Class          = "Calendar",
    representation = representation(
        IsNationalHoliday = "function",
        IsWeekend         = "function"
    )
)


Calendar <- function(IsNationalHoliday,
                     IsWeekend = IsRegularWeekend) {
    new(Class             = "Calendar",
        IsNationalHoliday = IsNationalHoliday,
        IsWeekend         = IsWeekend)
}

setGeneric(
    name = "SetIsHoliday",
    def  = function(object) {
        standardGeneric("SetIsHoliday")
    } 
)

setMethod(
    f          = "SetIsHoliday",
    signature  = "Calendar",
    definition = function(object) {
        IsNationalHoliday <- object@IsNationalHoliday
        IsWeekend         <- object@IsWeekend
        function(date)  IsNationalHoliday(date) | IsWeekend(date)
    } 
)

setGeneric(
    name = "SetIsBusinessDay",
    def  = function(object) {
        standardGeneric("SetIsBusinessDay")
    } 
)

setMethod(
    f          = "SetIsBusinessDay",
    signature  = "Calendar",
    definition = function(object) {
        IsHoliday <- SetIsHoliday(object)
        function(date) !IsHoliday(date)
    } 
)

setGeneric(
    name = "SetEndOfMonth",
    def  = function(object) {
        standardGeneric("SetEndOfMonth")
    } 
)

setMethod(
    f          = "SetEndOfMonth",
    signature  = "Calendar",
    definition = local(
        expr = {
            lastDayInNonLeapYear <- c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
            LastDayOfMonth       <- function(date) {
                mm      <- lubridate::month(date)
                lastDay <- lastDayInNonLeapYear[mm]
                if (lubridate::leap_year(date) & mm == 2) {
                    lastDay + 1
                } else {
                    lastDay
                }
                ifelse(test = lubridate::leap_year(date) & mm == 2,
                       yes  = lastDay + 1,
                       no   = lastDay)
            }
            
            function(object) {
                IsHoliday <- SetIsHoliday(object)
                
                function(date) {
                    lastDate      <- date
                    day(lastDate) <- LastDayOfMonth(lastDate)
                    dateNum <- vapply(X         = lastDate,
                                      FUN       = function(eom) {
                                          while (IsHoliday(eom)) {
                                              eom <- eom %m-% days()
                                          }
                                          
                                          eom
                                      },
                                      FUN.VALUE = numeric(1))
                    AsDate(dateNum)
                }
            }
        }
    )
)