R/sinodate.R

In chainsawriot/sinodate: S4 class to represent date in Chinese calendar (Mandarin: Nongli, Cantonese: Nung Lik)

require(lubridate)
lookupData <- function(lunarYearInt, lunarMonthInt, lookup) {
	### magic numbers
    lunarMonthData <- c(
    0xF0EA4, 0xF1D4A, 0x52C94, 0xF0C96, 0xF1536, 0x42AAC, 0xF0AD4, 0xF16B2, 0x22EA4, 0xF0EA4,  # 1901-1910
    0x6364A, 0xF164A, 0xF1496, 0x52956, 0xF055A, 0xF0AD6, 0x216D2, 0xF1B52, 0x73B24, 0xF1D24,  # 1911-1920
    0xF1A4A, 0x5349A, 0xF14AC, 0xF056C, 0x42B6A, 0xF0DA8, 0xF1D52, 0x23D24, 0xF1D24, 0x61A4C,  # 1921-1930
    0xF0A56, 0xF14AE, 0x5256C, 0xF16B4, 0xF0DA8, 0x31D92, 0xF0E92, 0x72D26, 0xF1526, 0xF0A56,  # 1931-1940
    0x614B6, 0xF155A, 0xF0AD4, 0x436AA, 0xF1748, 0xF1692, 0x23526, 0xF152A, 0x72A5A, 0xF0A6C,  # 1941-1950
    0xF155A, 0x52B54, 0xF0B64, 0xF1B4A, 0x33A94, 0xF1A94, 0x8152A, 0xF152E, 0xF0AAC, 0x6156A,  # 1951-1960
    0xF15AA, 0xF0DA4, 0x41D4A, 0xF1D4A, 0xF0C94, 0x3192E, 0xF1536, 0x72AB4, 0xF0AD4, 0xF16D2,  # 1961-1970
    0x52EA4, 0xF16A4, 0xF164A, 0x42C96, 0xF1496, 0x82956, 0xF055A, 0xF0ADA, 0x616D2, 0xF1B52,  # 1971-1980
    0xF1B24, 0x43A4A, 0xF1A4A, 0xA349A, 0xF14AC, 0xF056C, 0x60B6A, 0xF0DAA, 0xF1D92, 0x53D24,  # 1981-1990
    0xF1D24, 0xF1A4C, 0x314AC, 0xF14AE, 0x829AC, 0xF06B4, 0xF0DAA, 0x52D92, 0xF0E92, 0xF0D26,  # 1991-2000
    0x42A56, 0xF0A56, 0xF14B6, 0x22AB4, 0xF0AD4, 0x736AA, 0xF1748, 0xF1692, 0x53526, 0xF152A,  # 2001-2010
    0xF0A5A, 0x4155A, 0xF156A, 0x92B54, 0xF0BA4, 0xF1B4A, 0x63A94, 0xF1A94, 0xF192A, 0x42A5C,  # 2011-2020
    0xF0AAC, 0xF156A, 0x22B64, 0xF0DA4, 0x61D52, 0xF0E4A, 0xF0C96, 0x5192E, 0xF1956, 0xF0AB4,  # 2021-2030
    0x315AC, 0xF16D2, 0xB2EA4, 0xF16A4, 0xF164A, 0x63496, 0xF1496, 0xF0956, 0x50AB6, 0xF0B5A,  # 2031-2040
    0xF16D4, 0x236A4, 0xF1B24, 0x73A4A, 0xF1A4A, 0xF14AA, 0x5295A, 0xF096C, 0xF0B6A, 0x31B54,  # 2041-2050
    0xF1D92, 0x83D24, 0xF1D24, 0xF1A4C, 0x614AC, 0xF14AE, 0xF09AC, 0x40DAA, 0xF0EAA, 0xF0E92,  # 2051-2060
    0x31D26, 0xF0D26, 0x72A56, 0xF0A56, 0xF14B6, 0x52AB4, 0xF0AD4, 0xF16CA, 0x42E94, 0xF1694,  # 2061-2070
    0x8352A, 0xF152A, 0xF0A5A, 0x6155A, 0xF156A, 0xF0B54, 0x4174A, 0xF1B4A, 0xF1A94, 0x3392A,  # 2071-2080
    0xF192C, 0x7329C, 0xF0AAC, 0xF156A, 0x52B64, 0xF0DA4, 0xF1D4A, 0x41C94, 0xF0C96, 0x8192E,  # 2081-2090
    0xF0956, 0xF0AB6, 0x615AC, 0xF16D4, 0xF0EA4, 0x42E4A, 0xF164A, 0xF1516, 0x22936           # 2090-2099
    )
    referenceDate <- as.Date("1901-2-19")
    maxDate <- as.Date("2100-2-18")
    lYear <- 1901 ## Initial L Year, Month and Day are 1901, 1, 1. The day one of the Lunar Calendar in this program
    lMonth <- 1
    lDay <- 1
    getYearDayCount <- function(lunarYearInt) { ### TODO: to calulate all totalDays to eliminate this wasteful calculation
      lunMonData <- lunarMonthData[lunarYearInt - year(referenceDate) + 1]
      totalDays <- 0
      nonleap <- bitwShiftR(lunMonData, 16) == 15
      maxMonth <- ifelse(nonleap, 12, 13)
      for (i in 1:maxMonth) {
        day <- getMonthDayCount(lunarYearInt, i)
        totalDays <- totalDays + day
      }
      return(totalDays)
    }
    getMonthDayCount <- function(lunarYearInt, lunarMonthInt) {
      lunMonData <- lunarMonthData[lunarYearInt - year(referenceDate) + 1]
      return(29 +  bitwAnd(bitwShiftR(lunMonData, lunarMonthInt), 1))
    }
    getLeapMonth <- function(lunarYearInt) {
      return(bitwShiftR(lunarMonthData[lunarYearInt - year(referenceDate) + 1], 16))
      
  }
    if (lookup=="params") {
        return(list(referenceDate=referenceDate, maxDate=maxDate, lYear=lYear, lMonth=lMonth, lDay=lDay))
    } else if (lookup=="year") {
        return(getYearDayCount(lunarYearInt=lunarYearInt))
    } else if (lookup=="month") {
        return(getMonthDayCount(lunarYearInt=lunarYearInt, lunarMonthInt=lunarMonthInt))
    } else if (lookup=="leap") {
        return(getLeapMonth(lunarYearInt))
    } else {
        stop("Invalid lookup parameter")
    }
}


validity.sinodate <- function(object) {
    params <- lookupData(lookup="params")
    referenceDate <- params$referenceDate
    maxDate <- params$maxDate
    if (length(object@year) != 1 | length(object@year) != 1 | length(object@day) != 1) {
        return("Year, month and day must be singular")
    }
    if (object@month < 1 | object@month > 12 | object@day < 1 | object@day > 30) {
        return("Invalid month / Day")
    }
    if (object@year < year(referenceDate) | object@year > year(maxDate)) {
        return(paste0("Out of sinodate supported range:", referenceDate, " to ", maxDate))
    }
    leapMonth <- lookupData(object@year,lookup="leap")
    if (object@leap & object@month != leapMonth) {
        return(paste0(object@month, " is not a leap month."))
    }
    if (object@leap & object@month == leapMonth) {
        testMonth <- object@month + 1
    } else if (leapMonth <=12 & object@month > leapMonth) {
        testMonth <- object@month + 1
    } else {
        testMonth <- object@month
    }
    if (object@day > lookupData(object@year, testMonth, lookup="month")) {
        return("Day exceeds number of day.")
    }
    return(TRUE)
}

# constructor functions, either use sinodate or as.sinodate

sinodate <- setClass("sinodate", representation(year = 'numeric', month = 'numeric', day = 'numeric', leap = 'logical'), prototype = list(leap = FALSE), validity = validity.sinodate) 

setMethod('show', signature = 'sinodate', definition = 
          function(object){
              cat(paste0("SD: ",object@year, "-", object@month, ifelse(object@leap, "(Leap)", ""), "-", object@day,"\n"))
          })

### automatically formatting the string of x to a lunar date
### should be in the format of "2012-01-30". Leap Month should be denoted as "1995-08L-12"
### don't want to depend on stringr, use built-in regex functions instead

char2sinodate <- function(x) {
    if (class(x) != "character" | !grepl("^[0-9]{1,4}[-/ ][0-9]{1,2}[Ll]?[-/ ][0-9]{1,2}$", x)) {
        stop("invalid input: x must be in the format of 2012-01-03 or 1995/08L/12")
    }
    elements <- unlist(strsplit(x, "[-/ ]"))
    lYear <- as.integer(elements[1])
    if (grepl("[Ll]$", elements[2])) {
        lLeap <- TRUE
    } else {
        lLeap <- FALSE
    }
    lMonth <- as.integer(sub("[Ll]$", "",  elements[2]))
    lDay <- as.integer(elements[3])
    return(sinodate(year = lYear, month = lMonth, day = lDay, leap = lLeap))
}

# represent sinodate as cantonese representation

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

setMethod(f = "cantonese", signature = "sinodate", definition = function(object, withZodiac=FALSE) {
    ## magic numbers
    stems <- c("甲", "乙", "丙", "丁", "戊", "己", "庚", "辛", "壬", "癸")
    branches <- c("子", "丑", "寅", "卯", "辰", "巳", "午", "未", "申", "酉", "戌", "亥")
    zodiac <- c("鼠", "牛", "虎", "兔", "龍", "蛇", "馬", "羊", "猴", "鷄", "狗", "豬") ### Cantonese version, not Vietnamese, OK?
    prefixDay <- c("初", "十", "廿", "卅")
    numerals <- c("一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "十一", "十二")
    ## actual calculation
    stemIndex <- (object@year-3) %% 10
    stemIndex <- ifelse(stemIndex==0, length(stems), stemIndex)
    branchIndex <- (object@year - 3) %% 12
    branchIndex <- ifelse(branchIndex==0, length(branches), branchIndex)
    if (object@month == 1) {
        monthStr <- "正" 
    } else {
        monthStr <- numerals[object@month]
    }
    monthStr <- ifelse(object@leap, paste0("閏", monthStr), monthStr)
    dayStr <- paste0(prefixDay[(object@day %/% 10) + 1], ifelse(object@day %% 10 == 0, "", numerals[object@day %% 10]))
    dayStr <- ifelse(object@day == 10, paste0("初", dayStr), dayStr)
    zodiacStr <- ifelse(withZodiac, paste0("肖", zodiac[branchIndex]), "")
    return(paste0(stems[stemIndex], branches[branchIndex], "年", monthStr, "月", dayStr, "日", zodiacStr))
})

# for compatibility reason

as.character.sinodate <- function(x, ...) {
    cantonese(x, ...)
}

#cantonese(as.sinodate("1981-06-20"))
#cantonese(as.sinodate("1981-06-20"), TRUE)
#as.character(as.sinodate("1981-06-20"))
#as.character(as.sinodate("1981-06-20"), TRUE)

convertdate <- function(gDate) {
    params <- lookupData(lookup="params")
    referenceDate <- params$referenceDate
    maxDate <- params$maxDate
    lYear <- params$lYear
    lMonth <- params$lMonth
    lDay <- params$lDay    
### assert gDate >= referenceDate and <= maxDate
    if (gDate < referenceDate | gDate > maxDate) {
        stop(paste0("gDate out of the supported range:", referenceDate, " to ", maxDate))
    }
    timeSpan <- as.integer(gDate - referenceDate)
    ### get the number of day of a given year
    yearDayCount <-  lookupData(lunarYearInt = lYear, lookup="year")
    while (timeSpan >= yearDayCount) {
        timeSpan <- timeSpan - yearDayCount
        lYear <- lYear + 1
        yearDayCount <- lookupData(lunarYearInt = lYear, lookup="year")
    }
    monthDayCount <- lookupData(lunarYearInt=lYear, lunarMonthInt = lMonth, lookup="month")
    while (timeSpan >= monthDayCount) {
        timeSpan <- timeSpan - monthDayCount
        lMonth <- lMonth + 1
        monthDayCount <- lookupData(lunarYearInt=lYear, lunarMonthInt = lMonth, lookup="month")
    }
    leapMonth <-  lookupData(lunarYearInt=lYear, lookup="leap")
    lMonthIsLeap <- FALSE
    if (lMonth > leapMonth) {
        lMonth <- lMonth - 1
        if (lMonth == leapMonth) {
            lMonthIsLeap <- TRUE
        }
    }
    lDay <- lDay + timeSpan
    return(sinodate(year = lYear, month = lMonth, day = lDay, leap = lMonthIsLeap))
}

#convertDate(as.Date("1981-07-21"))
#convertDate(as.Date("2014-10-24"))
#cantonese(convertDate(as.Date("2014-9-28")))

as.sinodate <- function(x, gregorian = FALSE) {
    if (class(x) == "character" & !gregorian) {
        return(char2sinodate(x))
    } else if (class(x) == "character" & gregorian) {
        return(convertdate(as.Date(x)))
    } else if (class(x) == "Date") {
        return(convertdate(x))
    } else {
        stop("x must be in the class of character or Date")
    }
}


#utils::str(sinodate)

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


setMethod(f = "toDate", signature = "sinodate", definition = function(object, ignoreleap = FALSE) {
    params <- lookupData(lookup="params")
    referenceDate <- params$referenceDate
    maxDate <- params$maxDate
    lYear <- params$lYear
    lMonth <- params$lMonth
    lDay <- params$lDay
    timeSpan <- 0
    for (y in year(referenceDate):(object@year-1)) {
      timeSpan <- timeSpan + lookupData(y, lookup="year")
    }
    #print(timeSpan)
    leapMonth <-  lookupData(object@year, lookup="leap")
    offsetMonth <- object@month-1
    if (object@month > leapMonth) { ## adjusted for the leap month
      offsetMonth <- offsetMonth + 1
    }
    if (object@month > 1) {
      for (m in 1:offsetMonth) {
        timeSpan <- timeSpan + lookupData(object@year, m, lookup="month")
      }
    }
    timeSpan = timeSpan + object@day - 1
    #print(timeSpan)
    if (leapMonth == object@month) {
      res <- c((referenceDate + days(timeSpan)), (referenceDate + days(timeSpan + lookupData(object@year, leapMonth, lookup="month"))))
      #print(res)
      if (object@leap) {
          return(res[2])
      } else if (!ignoreleap) {
          return(res)
      } else {
          return(res[1])
      }      
    } else {
      return(referenceDate + days(timeSpan))
    }}
          )

as.Date.sinodate <- function(x, ...) {
    toDate(x, ...)
}