R/base-weekdays.R

In timeDate: Rmetrics - Chronological and Calendar Objects

# 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


################################################################################
# FUNCTION:                 DATE FUNCTIONS:
#  #.fjulian                  Transforms formatted dates to julian day numbers
#  .julian                   Implements SPlus like 'julian'
#  #.isPOSIX                  Checks for an object of class POSIX
#  #.by2seconds               Converts 'by' string into numeric value of seconds
################################################################################


## .fjulian <-
##     function(fdates, origin = 19600101, order = 'mdy', cc = NULL, swap = 20)
## {
##     # A function implemented by Diethelm Wuertz

##     # Description:
##     #   Transforms formatted dates (fdates) from several formats
##     #   as 8/11/73 11Aug1973, ... into ISO-8601 Gregorian dates
##     #   ... makes use of C-Program char_date.c implemented by
##     #   Terry Therneau

##     # Notes:
##     #   cc - Century, becoming obsolete with the introduction of swap.

##     # Example:
##     #   require(date)
##     #   fdates = c("8/11/73", "08-11-73", "August 11 1973", "Aug11/73")
##     #   .fjulian(fdates)
##     #   fdates = c("11/8/73", "11-08-73", "11 August 1973", "11Aug73")
##     #   .fjulian(fdates, order = 'dmy')

##     # Note:
##     #   Requires R-package "date"

##     # FUNCTION:

##     stopifnot(require("date"))


##     # Formats:
##     order.vec <-
##         switch(order,
##                'ymd'= c(1,2,3),
##                'ydm'= c(1,3,2),
##                'mdy'= c(2,3,1),
##                'myd'= c(2,1,3),
##                'dym'= c(3,1,2),
##                'dmy'= c(3,2,1),
##                stop("Invalid value for 'order' option"))
##     nn = length(fdates)
##     cd <- .C("char_date",
##              as.integer(nn),
##              as.integer(order.vec),
##              as.character(fdates),
##              month = integer(nn),
##              day = integer(nn),
##              year = integer(nn), PACKAGE = "date")[c("month", "day", "year")]

##     yy <- cd$year %% 100

##     # Swap:
##     cc = 19 + trunc(sign(swap-yy)+1)/2
##     year = cc*100 + yy

##     # Origin:
##     cc0 = origin %/% 1000000
##     yymmdd0 = origin - cc0*1000000
##     yy0 = yymmdd0 %/% 10000
##     mm0 = yymmdd0 %/% 100 - yy0*100
##     dd0 = yymmdd0 - yy0*10000 - mm0*100

##     # Result:
##     .julian(cd$month, cd$day, year, origin = c(mm0, dd0, cc0*100+yy0))
## }

.julian <- function(m, d, y, origin = c(month = 1, day = 1, year = 1960)) {
    # A function implemented by Diethelm Wuertz

    # Description:
    #   This function is a synonyme for Splus' "julian()" with the
    #   same list of arguments.

    # Note:
    #   SPlus like function.

    # FUNCTION:

    # Implementation:
    only.origin = all(missing(m), missing(d), missing(y))
    if(only.origin) m = d = y = NULL    # return days since origin
    nms = names(d)
    max.len = max(length(m), length(d), length(y))
    # prepend new origin value and rep out to common max. length:
    m = c(origin[1], rep(m, length = max.len))
    d = c(origin[2], rep(d, length = max.len))
    y = c(origin[3], rep(y, length = max.len))
    # code from julian date in the S book (p.269)
    y = y + ifelse(m > 2, 0, -1)
    m = m + ifelse(m > 2, -3, 9)
    c = y %/% 100
    ya = y - 100 * c
    out = (146097 * c) %/% 4 + (1461 * ya) %/% 4 +
        (153 * m + 2) %/% 5 + d + 1721119
    # now subtract the new origin from all dates
    if(!only.origin) {
        out <- if(all(origin == 0)) out[-1] else out[-1] - out[1]
    }
    names(out) = nms

    # Return Value:
    out
}

## 2023-01-08 GNB: removed .isPOSIX() since it is not used anywhere in the package.
## 
## .isPOSIX <-
##     function(x)
## {
##     # A function implemented by Diethelm Wuertz
## 
##     # Description:
##     #   Checks for an object of class POSIX
## 
##     # FUNCTION:
## 
##     # Check:
##     ans = inherits(x, "POSIXt")
## 
##     # Return Value:
##     ans
## }

## TODO: rename, document and export this function? not used anywhere in the package
## .by2seconds <-
##     function(by = "1 h")
## {
##     # A function implemented by Diethelm Wuertz
## 
##     # Description:
##     #   Convert 'by' string into numeric value of seconds
## 
##     # FUNCTION:
## 
##     # Convert:
##     by = strsplit(by, " ")[[1]]
##     byTime = as.integer(by[1])
##     byUnits = substr(by[2], 1, 1)
##     timeUnits = c(1, 60, 3600)
##     names(timeUnits) = c("s", "m", "h")
##     bySeconds = byTime * timeUnits[byUnits]
##     names(bySeconds) = "secs"
## 
##     # Return Value:
##     bySeconds
## }

################################################################################