# This 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.
#
# This 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 this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA

# Copyrights (C)
# for this R-port:
#   1999 - 2008, Diethelm Wuertz, Rmetrics Foundation, GPL
#   Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
#   www.rmetrics.org
# for the code accessed (or partly included) from other R-ports:
#   see R's copyright and license files
# for the code accessed (or partly included) from contributed R-ports
# and other sources
#   see Rmetrics's copyright file


################################################################################
# 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:

    # Requires
    # 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"),
        PACKAGE = "date")
    nn = length(fdates)
    temp = .C("char_date",
        as.integer(nn),
        as.integer(order.vec),
        as.character(fdates),
        month = integer(nn),
        day = integer(nn),
        year = integer(nn),
        PACKAGE = "date")
    month = temp[[4]]
    day = temp[[5]]
    year = temp[[6]]
    yy = year - 100 * floor (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:
    ans = .julian(month, day, year, origin = c(mm0, dd0, cc0*100+yy0))

    # Return Value:
    ans
}


# ------------------------------------------------------------------------------


.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:

    # Selection:
    .R = TRUE
    .S = FALSE

    # Implementation under R:
    if(.R) {
        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) {
            if(all(origin == 0)) out = out[-1] else out = out[-1] - out[1] }
        names(out) = nms
        result = out }

    # Synonyme for S:
    if(.S) {
        result = julian(m = m, d = d, y = y, origin. = origin)}

    # Return Value:
    result
}


# ------------------------------------------------------------------------------


.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
}


# ------------------------------------------------------------------------------


.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
}


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