# ------------------------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------------------- # # # # File Name : date modifiers.r # # Last Updated Funclist : 19 Feb 2015, 12:52 PM (Thursday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : NA # # Packages Used via NS : lubridate # # # # ----------------------------------------------------------------------------------------------------------------------- # # # # seasonFromDate ( D, factors=TRUE ) # # today.string ( simple=TRUE, format=ifelse(isTRUE(simple), "%Y%m%d", "%Y-%m-%d") ) # # today ( ) # # now ( tz=getOption("default.tz", "America/New_York") ) # # EndOfMonth ( x ) # # nextMonth ( x, months.forward=1 ) # # prevMonth ( x, months.backward=1 ) # # monthFloor ( x ) # # monthCeiling ( x ) # # is.date_or_time ( x ) # # is.Date ( x ) # # is.POSIX ( x, recursive=TRUE, simplify=TRUE, clss="POSIXt" ) # # is.POSIXct ( x, ..., clss="POSIXct" ) # # is.POSIXlt ( x, ..., clss="POSIXlt" ) # # showDateFormats ( date=as.POSIXct("2014-03-09 17:57:01 EDT"), usenow=FALSE, useorigin=FALSE ) # # # # # # # # ----------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------- # ## SEE ALSO # ~/git/misc/rscripts/utils/weekdaysPer.r # ~/git/misc/rscripts/utils/DateTime_to_factors.r ## ------------------------------------------------------------ ## ## These three functions came from ## '~/git/orch/src/chartio/Create GPU Table from analytics.r' lastDateInMonth <- function(x) { if (!is.Date(x)) warning("x should be a 'Date', it is a '", class(x)[[1]], "'") lubridate::ceiling_date(x+1, unit="month") - 1 } firstDateInMonth <- function(x) { if (!is.Date(x)) warning("x should be a 'Date', it is a '", class(x)[[1]], "'") lubridate::floor_date(x, unit="month") } iTunesDaysInMonth <- function(x) { if (!is.Date(x)) warning("x should be a 'Date', it is a '", class(x)[[1]], "'") ## Every 3rd month is 35 days, the rest are 28 days ifelse(data.table::month(x) %% 3, 35, 28) } ## ------------------------------------------------------------ ## unlistDateTime <- function(x, use.names=TRUE, origin.date=.origin, origin.posix=.origin.utc) { ## There are two problems in simply calling unlist(x) ## (1) If x is a mix of posix and date, the results will be muggled ## (2) Even if x is uniformed, the results are converted to integer representation ## Confirm all elements are date/time if (!all(sapply(x, is.date_or_time))) stop ("x must be a list of date or time values") wh.posix <- sapply(x, is.POSIXct) ret <- as.Date(unlist(x, use.names=use.names), origin=origin.date) ## If there is a mix of posix and date, we need to convert to date then posix if (any(wh.posix)) { ret_posix <- as.POSIXct(unlist(x, use.names=use.names), origin=origin.posix) if (any(!wh.posix)) ret_posix[!wh.posix] <- as.POSIXct(paste(ret[!wh.posix], "00:00:00")) ret <- ret_posix } return(ret) } makeStringFromDateRange <- function(dateRange, year=FALSE, format=paste0("%b %e", if (year) " %Y")) { ## Converts ## c("2015-01-29", "2015-02-08") ## to "Jan 29 2015 - Feb 8 2015" L <- length(dateRange) if (L != 2) warning ("dateRange has ", L, " element(s) -- it should have exactly 2") pasteC(format.Date(dateRange, format=format), C=" - ") } seasonFromDate <- function(D, factors=TRUE) { # given a date, return a factor/string of the corresponding Season # grab the month from the date M <- lubridate::month(D) # list of season values, in order Seasons <- c("Winter", "Spring", "Summer", "Fall") # Compute the numerical season-value M.as.season <- ((M %% 12) %/% 3) + 1 if (factors) return(factor(M.as.season, levels=c(1, 2, 3, 4), labels=Seasons)) return(Seasons[M.as.season]) } ## Wrapper today.string <- function(simple=TRUE, format=ifelse(isTRUE(simple), "%Y%m%d", "%Y-%m-%d")) { format(Sys.Date(), format=format) } today <- function() { Sys.Date() } now <- function(tz=getOption("default.tz", "America/New_York")) { as.tz(Sys.time(), tz=tz) } get_tz <- function(x, default="", showWarnings=TRUE) { if (!is.POSIX(x)) { verboseMsg(showWarnings, "x must be a POSIX. It is ", class(x) [[1]], " -- returning NA_character_") return(NA_character_) } ret <- attr(x, "tzone", exact=TRUE) if (is.null(ret) && is.POSIXct(x)) ret <- attr(as.POSIXlt(x), "tzone", exact=TRUE) ## POSIXlt, I believe will generally show a hierarchy, where the last one is most detailed if (length(ret) > 1) ret %<>% tail(1) if (is.null(ret)) warning("x is class '", class(x)[[1]], "' but does not have a 'tzone' attribute") if (ret == "") ret <- default return(ret) } if (FALSE) { ## EXAMPLES FOR as.tz() x.num <- 1444189665 x.msk <- as.POSIXct(x.num, origin=.origin.utc, tz="Europe/Moscow") # [1] "2015-10-07 06:47:45 MSK" x.edt <- as.POSIXct(x.num, origin=.origin.utc, tz="America/New_York") # [1] "2015-10-06 23:47:45 EDT" x.pdt <- as.POSIXct(x.num, origin=.origin.utc, tz="America/Los_Angeles") # [1] "2015-10-06 20:47:45 PDT" x.date <- as.Date("2015-10-07") as.tz(x.msk, tz="America/Montevideo") as.tz(x.edt, tz="America/Montevideo") as.tz(x.pdt, tz="America/Montevideo") as.tz(x.date, tz="Europe/Moscow") as.tz(x.date, tz="America/New_York") as.tz(x.date, tz="America/Los_Angeles") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~ as.POSIXct(x, tz="Europe/Moscow") as.POSIXct(x, tz="America/New_York") base:::.POSIXct(x, tz="America/Los_Angeles") base:::.POSIXct(x.edt, tz="America/Los_Angeles") base:::.POSIXct(x.msk, tz="America/Los_Angeles") structure(x.msk, class = c("POSIXct", "POSIXt"), tzone = tz) structure(x.edt, class = c("POSIXct", "POSIXt"), tzone = tz) structure(x.pdt, class = c("POSIXct", "POSIXt"), tzone = tz) debug(.POSIXct) .POSIXct(x.msk, tz="America/Los_Angeles") as.POSIXct(x.msk, tz="America/Los_Angeles") .POSIXctq base:::as.POSIXct %P% . methods(as.POSIXct) debug(as.POSIXct) as.numeric(as.tz(x.msk, tz="UTC")) == x.num as.numeric(as.tz(x.edt, tz="UTC")) == x.num as.numeric(as.tz(x.pdt, tz="UTC")) == x.num get_tz(x.msk) get_tz(x.edt) get_tz(x.pdt) as.numeric(as.tz(x.msk, tz="PDT")) as.numeric(as.tz(x.msk, tz="America/Los_Angeles")) as.numeric(as.tz(x.msk, tz="PDT")) == x.num as.numeric(as.tz(x.edt, tz="PDT")) == x.num as.numeric(as.tz(x.pdt, tz="PDT")) == x.num # ------------------------------------ x.no_tz <- as.POSIXct("2015-10-07 06:47:44") x.yes_tz <- as.POSIXct("2015-10-07 06:47:44", tz="Europe/Moscow") as.numeric(x.no_tz) as.numeric(as.POSIXct("2015-10-07 06:47:44", tz="America/New_York")) rd1 <- rd[[1]] as.numeric(rd1) as.numeric(as.POSIXct("2013-10-14 20:00:00 EDT")) as.numeric(as.utc(rd1)) structure(rd, tzone="UTC") structure(as.POSIXct(unclass(x)*86400, origin=.origin.utc), tzone="UTC") lsosdt() dput(x.no_tz) as.tz(x.no_tz, tz="UTC") as.tz(x.yes_tz, tz="UTC") as.tz(x=Sys.time(),tz.current="America/New_York") dput(as.POSIXct(format(x, tz = tz.current), tz = tz.current)) dput(as.POSIXct(format(x, tz = "UTC"), tz = tz.current)) as.numeric(x) as.POSIXct(1444189665, origin=.origin.utc, tz="UTC") format(x, tz = tz.current) dput(as.tz(Sys.time())) format(x, tz="America/Los_Angeles",usetz=TRUE) format(x, tz="America/Los_Angeles",usetz=FALSE) format(x, tz="America/Los_Angeles") format(x, tz="Europe/Moscow", usetz=TRUE) } as.utc <- function(x, origin=.origin.utc) { as.tz(x, tz="UTC", origin=origin) } as.tz <- function(x=Sys.time(), tz=getOption("default.tz", "America/New_York"), tz.current="DEPRECATED", origin=.origin.utc) { ## Assigns or converts timezone ## ## NOTE TO SELF ON format.POSIXct() ## The following converts x to a string at the appropriate time zone ## usetz simply indicates that the timezone should be shown in the string output ## (note that if the format argument is explicit and it contains tz already, usetz will duplicate the tz output) ## format.POSIXct(x, tz=DesiredTimeZone, usetz=TRUE) ## ## GOAL: Given an x, "convert" it to tz ## where, "convert" means ## if x has a timezone, adjust the time and add the tz ## if x is a date or does NOT have a timezone, simply paste the tz to it ## ## 2015-10-05 -- I am not sure if tz.current is actually accomplishing anything, or if the timezone is just being taken from x if (!missing(tz.current)) warning ("tz.current has been deprecated -- it is not used. perhaps we need a convert_tz() function ??") ## taken from .POSIXct() in base if (is.POSIX(x)) structure(x, class = c("POSIXct", "POSIXt"), tzone = tz) else if (inherits(x, "Date")) structure(unclass(x)*86400, class = c("POSIXct", "POSIXt"), tzone="UTC") # as.POSIXct(format(x, tz="UTC", format="%Y-%m-%d 00:00:00", usetz=TRUE), tz=tz) else as.POSIXct(format(as.POSIXct(x, origin=origin), tz=tz, usetz=TRUE), tz=tz) } EndOfMonth <- function(x) { # Note: monthCeiling goes to start of the next month. EndOfMonth goes to end of current month if (!is.Date(x)) x <- as.Date(x, origin=.origin) nextMonth(monthFloor(x))-1 } nextMonth <- function(x, months.forward=1) lubridate::`%m+%`(x, months(months.forward)) prevMonth <- function(x, months.backward=1) lubridate::`%m+%`(x, months(-months.backward)) monthFloor <- function(x) { if (!inherits(x, "Date")) # stop("x must be a Date") x <- as.Date(x, origin=.origin) lubridate::floor_date(x, unit="month") } monthCeiling <- function(x) { # Note: monthCeiling goes to start of the next month. EndOfMonth goes to end of current month if (!inherits(x, "Date")) # stop("x must be a Date") x <- as.Date(x, origin=.origin) lubridate::ceiling_date(x, unit="month") } is.date_or_time <- function(x) { inherits(x, c("Date", "POSIXct", "POSIXt", "POSIXlt", "POSIXt")) } is.Date <- function(x) inherits(x, "Date") is.POSIX <- function(x, recursive=TRUE, simplify=TRUE, clss="POSIXt") { if (!length(x)) return(x) if (is.list(x) && recursive && !inherits(x, "POSIXlt")) return(sapply(x, is.POSIX, recursive=recursive, simplify=simplify, clss=clss)) # any(grepl("POSIX", class(x))) inherits(x, clss) } is.POSIXct <- function(x, ..., clss="POSIXct") { is.POSIX(x, ..., clss=clss) } is.POSIXlt <- function(x, ..., clss="POSIXlt") { is.POSIX(x, ..., clss=clss) } showDateFormats <- function(date=as.POSIXct("2014-03-09 17:57:01 EDT"), usenow=FALSE, useorigin=FALSE) { ## The specific date is chosen because it has 0's in the month, day & hour, and is also past 12 pm if (usenow) date <- Sys.time() else if (useorigin) date <- as.POSIXct("1970-01-01 00:00.00 UTC") Ll <- c(LETTERS, letters) Ll <- Ll[order(tolower(Ll))] frmts <- sprintf("%%%s", c(LETTERS, letters)) formatted <- sapply(frmts, function(x) format(date, x)) ret <- matrix(sprintf("%8s : %-24s", names(formatted), formatted), ncol=2) cat(sprintf("\n%10s Sample Date is %s %1$-10s\n %s\n", "-----", format(date, "%Y-%b-%d %T %Z"), pasteR(50))) cat(apply(ret, 1, pasteC), sep="\n") return(invisible(formatted)) } ### ------------------------------------------------------------------- ## ## Simple iso8601 conversion. ## These are not robust, but sufficient for use with snowflake and spotify api as.iso8601 <- function(x, tz="UTC", ...) { # yyyy-MM-ddTHH:mm:ss UseMethod("as.iso8601") } as.iso8601.default <- function(x, ...) { ## TODO # if (is.null(x)) classAppend_(x, "iso8601") return (x) } as.iso8601.character <- function(x) { ## TODO: test if x is correctly formatted classAppend_(x, "iso8601") return(x) } as.iso8601.Date <- function(x) { (classAppend_(format(x, "%Y-%m-%dT%H:%M:%S"), "iso8601")) } as.iso8601.POSIXct <- function(x, tz="UTC") { (classAppend_(format(as.tz(x, tz=tz), "%Y-%m-%dT%H:%M:%S"), "iso8601")) } as.iso8601.POSIXlt <- function(x, tz="UTC") { warning ("timezone is not properly implemented in as.iso8601.POSIXlt()") (classAppend_(format(x, "%Y-%m-%dT%H:%M:%S"), "iso8601")) } as.POSIXct.iso8601 <- function(x, tz="", format="%Y%m%dT%H%M%S", ...) { x <- cleanString.iso8601(x) as.POSIXct(x=x, tz=tz, format=format, ...) } cleanString.iso8601 <- function(x) { stopifnot(is.character(x)) # gsub("_|\\:", "", gsub("(\\d)T(\\d)", "\\1_\\2", x)) ret <- gsub("-|\\:|\\s*", "", x) classUnappend_(ret, "iso8601") return(ret) }