#' Parse period dates to POSIXct date objects
#'
#' Converts a vector of period names in format
#' yyyy, yyyy-mm, yyyy-mm-dd, mmm-mmm yy, mmm yyyy, dd/mm/yyyy and
#' dd/mm/yyyy-dd/mm/yyyy into a POSIXct/POSIXt date object.
#' @param x The vector of \code{char} to convert.
#' @param by The time aggregation. Deprecated as this can be deduced from x.
#' @param us.format Whether to assume US date format when parsing.
#' @importFrom lubridate parse_date_time2
#' @examples
#' PeriodNameToDate(2010:2014)
#' PeriodNameToDate(c("2010-01", "2010-02"))
#' PeriodNameToDate(c("26/02/2011-1/01/2012", "2/01/2012-8/01/2012"))
#' @noRd
parsePeriodDate <- function(x, us.format = NULL)
{
## Need to be more strict with separators if no days in the periods because false
## positives are more likely e.g. dd-mm-yy could parsed as the period mm-mm-yy
## if '-' is allowed for both separators
## \p{Pd} is unicode dash punctuation property
date.parts.sep.no.day <- "(?:[[:space:]]+|[,/\\p{Pd}])"
period.sep.no.day <- "[[:space:]]*[,/\\p{Pd}][[:space:]]*"
date.parts.sep.with.day <- "[[:space:]]*[,/ \\p{Pd}][[:space:]]*"
period.sep.with.day <- "[[:space:]]*[,/ \\p{Pd}][[:space:]]*"
m.or.b.month <- bOrMMonthRegexPatt()
year <- yearRegexPatt()
opt.year <- paste0("(", date.parts.sep.no.day, year, ")?")
period.regex.no.day <- paste0("^", m.or.b.month, opt.year, period.sep.no.day,
m.or.b.month, date.parts.sep.no.day, year, "$")
## period.regex.no.day <- "^[[:alpha:]]{3}-[[:alpha:]]{3} [[:digit:]]{2}$"
## # e.g.: 1/02/1999-8/02/1999
## period.regex.with.day <- paste0("^[[:digit:]]{1,2}/[[:digit:]]{1,2}/[[:digit:]]{4}-",
## "[[:digit:]]{1,2}/[[:digit:]]{1,2}/[[:digit:]]{4}$")
dd.mm.yyyy <- dayMonthYearRegexPatt(date.parts.sep.with.day)
mm.dd.yyyy <- monthDayYearRegexPatt(date.parts.sep.with.day)
period.regex.with.day.int <- paste0("^", dd.mm.yyyy, period.sep.with.day,
dd.mm.yyyy, "$")
period.regex.with.day.us <- paste0("^", mm.dd.yyyy, period.sep.with.day, mm.dd.yyyy, "$")
result <- NA
## Q quarters, e.g.: Apr-Jun 08
if (grepl(period.regex.no.day, x[1L], perl = TRUE, ignore.case = TRUE))
result <- parsePeriodWithoutDays(x, period.sep = period.sep.no.day,
date.part.sep = date.parts.sep.no.day)
else
{
is.weekly <- FALSE
if (is.null(us.format) || isTRUE(us.format))
is.weekly <- grepl(period.regex.with.day.us, x[1L], perl = TRUE,
ignore.case = TRUE)
if (is.null(us.format) || !us.format)
is.weekly <- is.weekly || grepl(period.regex.with.day.int, x[1L], perl = TRUE,
ignore.case = TRUE)
if (is.weekly)
result <- parsePeriodsWithDays(x, us.format, date.parts.sep.with.day)
}
if (any(is.na(result)))
result <- rep.int(NA, length(x))
result
}
#' @title{PeriodNameToDate}
#'
#' @description Converts a vector of period names in format
#' yyyy, yyyy-mm, yyyy-mm-dd, mmm-mmm yy, mmm yyyy, dd/mm/yyyy and
#' dd/mm/yyyy-dd/mm/yyyy into a Date.
#' @param x The vector of \code{char} to convert.
#' @param by The time aggregation. Deprecated as this can be deduced from x.
#' @param us.format Whether to assume US date format when parsing.
#' @importFrom lubridate parse_date_time2
#' @seealso AsDate
#' @examples
#' ## Deprecated; use AsDate instead
## PeriodNameToDate(2010:2014)
## PeriodNameToDate(c("2010-01", "2010-02"))
## PeriodNameToDate(c("26/02/2011-1/01/2012", "2/01/2012-8/01/2012"))
#' @export
PeriodNameToDate <- function(x, by, us.format = NULL)
{
.Deprecated("AsDate", package = "flipTime")
return(AsDate(x, us.format, on.parse.failure = "silent"))
if (any(c("POSIXct", "POSIXt") %in% class(x)))
return(x)
if (is.numeric(x))
x <- as.character(x)
# e.g.: Apr-Jun 08
period.regex.no.day <- "^[[:alpha:]]{3}-[[:alpha:]]{3} [[:digit:]]{2}$"
# e.g.: 1/02/1999-8/02/1999
period.regex.with.day <- "^[[:digit:]]{1,2}/[[:digit:]]{1,2}/[[:digit:]]{4}-[[:digit:]]{1,2}/[[:digit:]]{1,2}/[[:digit:]]{4}$"
if (all(grepl(period.regex.no.day, x))) # Q quarters, e.g.: Apr-Jun 08
result <- parsePeriodWithoutDays(x)
else if (all(grepl(period.regex.with.day, x))) # Q weekly periods, e.g.: 1/02/1999-8/02/1999
result <- parsePeriodsWithDays(x, us.format)
else
{
suppressWarnings(parsed.numeric <- as.numeric(x))
result <- if (any(is.na(parsed.numeric)) || all(parsed.numeric >= 1900 & parsed.numeric < 2100))
AsDate(x, us.format, on.parse.failure = "silent")
else
rep(NA, length(x))
}
if (any(is.na(result)))
result <- rep(NA, length(x))
result
}
#' Convert Q-quarterly date formats to R date objects
#'
#' Parses a character vector of date intervals in Q-quarterly date
#' format to obtain the start of the interval in R date-time objects
#' @param x Character vector assumed to have elements in date format
#' "%b-%b %y"; e.g. Apr-Jun 08.
#' @param period.sep Character string specifying how the start and end
#' points of the period are separated in the elements of \code{x}.
#' @param date.part.sep Character string specifying how months are
#' separated from years in the elements of \code{x}.
#' @return Vector containing the start of each period parsed to date
#' objects
#' @noRd
#' @importFrom lubridate dmy year year<-
parsePeriodWithoutDays <- function(x, period.sep = "[/\\p{Pd}]",
date.part.sep = "[[:space:]/\\p{Pd}]")
{
x.split <- strsplit(x, period.sep, perl = TRUE)
if (length(x.split[[1L]]) == 4L)
{
start.dat <- paste(vapply(x.split, `[`, 1L, FUN.VALUE = ""),
vapply(x.split, `[`, 2L, FUN.VALUE = ""), sep = "-")
end.dat <- paste(vapply(x.split, `[`, 3L, FUN.VALUE = ""),
vapply(x.split, `[`, 4L, FUN.VALUE = ""), sep = "-")
}else if (length(x.split[[1L]]) == 3L)
{
## don't allow %m/%m/%y to avoid matching %d/%m/%y
## allow %b/%b/%y
bMonth <- bMonthRegexPatt()
patt <- paste0("(", bMonth, "\\b.*){2}")
if (!grepl(patt, x[1L], perl = TRUE, ignore.case = TRUE))
return(NA)
start.dat <- vapply(x.split, `[`, 1L, FUN.VALUE = "")
end.dat <- paste(vapply(x.split, `[`, 2L, FUN.VALUE = ""),
vapply(x.split, `[`, 3L, FUN.VALUE = ""), sep = "-")
}else
{
start.dat <- vapply(x.split, `[`, 1L, FUN.VALUE = "")
end.dat <- vapply(x.split, `[`, 2L, FUN.VALUE = "")
}
end.yr <- regmatches(end.dat, regexpr("([0-9]{2}){1,2}$", end.dat))
opt.year <- paste0(date.part.sep, yearRegexPatt())
has.start.yr <- grepl(opt.year, start.dat, perl = TRUE, ignore.case = TRUE)
start <- paste0("01-", start.dat)
start[!has.start.yr] <- paste0(start[!has.start.yr], "-", end.yr)
end <- paste0("01-", end.dat)
start.dmy <- dmy(start, quiet = TRUE)
end.dmy <- dmy(end, quiet = TRUE)
## Need to handle cases where start year < end year
bad.idx <- which(start.dmy > end.dmy)
if (length(bad.idx))
year(start.dmy[bad.idx]) <- year(end.dmy[bad.idx]) - 1
start.dmy
}
#' @importFrom lubridate parse_date_time2
parsePeriodsWithDays <- function(x, us.format = NULL, sep = "[/-]")
{
## important to use non-capture groups for later call to regmatches()
dd.mm.yyyy <- dayMonthYearRegexPatt(sep)
mm.dd.yyyy <- monthDayYearRegexPatt(sep)
ords.int <- c("dmY", "dbY", "dby", "dmy")
ords.us <- c("mdY", "bdY", "bdy", "mdy")
if (is.null(us.format))
{
result.int <- parseDayMonthYear(x, dd.mm.yyyy, ords.int, TRUE)
result.us <- parseDayMonthYear(x, mm.dd.yyyy, ords.us, TRUE)
if (!any(is.na(result.int)) && !any(is.na(result.us)))
{ # starts dates are ambiguous, see if end date resolves ambiguity
result.end.int <- parseDayMonthYear(x, dd.mm.yyyy, ords.int, FALSE)
result.end.us <- parseDayMonthYear(x, mm.dd.yyyy, ords.us, FALSE)
if (!any(is.na(result.end.int)) && !any(is.na(result.end.us)))
warning("Date formats are ambiguous, US format has been used.")
if (!any(is.na(result.end.us)))
result <- result.us
else
result <- result.int
}
else if (!any(is.na(result.us)))
result <- result.us
else
result <- result.int
}
else if (us.format)
result <- parseDayMonthYear(x, mm.dd.yyyy, ords.us, TRUE)
else
result <- parseDayMonthYear(x, dd.mm.yyyy, ords.int, TRUE)
result
}
#' @noRd
#' @importFrom lubridate parse_date_time2
parseDayMonthYear <- function(x, pattern, ords, start = TRUE)
{
if (start)
pattern <- paste0("^", pattern, "\\b")
else
pattern <- paste0("\\b", pattern, "$")
dates <- unlist(regmatches(x, regexec(pattern, x, perl = TRUE,
ignore.case = TRUE)))
if (length(dates) != length(x))
return(rep.int(NA, length(x)))
for (ord in ords)
{
result <- parse_date_time2(dates, ord, exact = FALSE)
if (!any(is.na(result)))
break
}
result
}
#' @note Important to use non-capture groups due to later use of regmatches
#' @noRd
dayRegexPatt <- function()
"(?:[12][0-9]|3[01]|0?[0-9])"
#' @noRd
#' @note Need to use ignore.case = TRUE in all regex function calls as this pattern
#' only matches all lower case on its own.
bMonthRegexPatt <- function()
{
## Commented out code uses R's built in constants to make month regex
## xtra.m.part <- mapply(function(abb, full) sub(abb, "", full), month.abb, month.name)
## ## specify non-capture group, except for may, which has no extra part (i.e. abbrev == full)
## xtra.m.part[nchar(month.name) > 3] <- paste0("(?:", xtra.m.part[nchar(month.name) > 3], ")?")
## paste0("(?:", paste(tolower(month.abb), xtra.m.part, collapse = "|", sep = ""), ")")
paste0("(?:jan(?:uary)?|feb(?:ruary)?|mar(?:ch)?|apr(?:il)?|may|jun(?:e)?|",
"jul(?:y)?|aug(?:ust)?|sep(?:tember)?|oct(?:ober)?|nov(?:ember)?|dec(?:ember)?)")
}
#' @noRd
mMonthRegexPatt <- function()
"(?:1[012]|0?[1-9])"
#' @noRd
bOrMMonthRegexPatt <- function()
paste0("(?:", bMonthRegexPatt(), "|", mMonthRegexPatt(), ")")
#' @noRd
yearRegexPatt <- function()
"(?:[0-9]{2}){1,2}"
#' @noRd
dayMonthYearRegexPatt <- function(sep = "[/-]", day.optional = FALSE)
paste0(if (day.optional) "(?:", dayRegexPatt(), sep, if (day.optional) ")?",
bOrMMonthRegexPatt(), sep, yearRegexPatt())
#' @noRd
monthDayYearRegexPatt <- function(sep = "[/-]", day.optional = FALSE)
paste0(bOrMMonthRegexPatt(), sep, if (day.optional) "(?:", dayRegexPatt(),
sep, if (day.optional) ")?", yearRegexPatt())
#' @noRd
yearMonthDayRegexPatt <- function(sep = "[/-]", day.optional = FALSE)
paste0(yearRegexPatt(), sep, bOrMMonthRegexPatt(),
if (day.optional) "(?:", sep, dayRegexPatt(), if (day.optional) ")?")
#' @noRd
yearDayMonthRegexPatt <- function(sep = "[/-]", day.optional = FALSE)
paste0(yearRegexPatt(),
if (day.optional) "(?:", sep, dayRegexPatt(), if (day.optional) ")?",
sep, bOrMMonthRegexPatt())
#' \code{CompleteListPeriodNames}
#'
#' @description Returns a vector that contains all the possible period dates.
#' @param x The vector of \code{char} to convert.
#' @param by The time aggregation.
#' @importFrom lubridate ymd
#' @export
CompleteListPeriodNames <- function(x, by)
{
if(by == "year")
{
x <- as.numeric(x)
return(as.character(min(x):max(x)))
}
observed.dates <- AsDate(x, on.parse.failure = "silent")
Period(seq(min(observed.dates), max(observed.dates), by = by), by)
}
#' Convert date objects to character strings
#'
#' @description Converts a date into a character.
#' @param x The date.
#' @param by The period used in the conversion (e.g., "week", "year"). Special
#' cases include:
#' \itemize{
#' \item \code{"quarter"}, which provides the month for the quarter as
#' YYYY-MM
#' \item \code{"nice.quarter"}, which provides the quarter in the form
#' Q1 2022
#' \item \code{"2-week"}, \code{"4-week"} , etc which provides multi-week
#' periods labeled with the first date in the corresponding period, e.g. "2
#' weeks commencing 2022-07-03". Requires to use to specify the anchor.date
#' argument as a point of reference.
#' }
#' @param anchor.date Supply a Date value to disambiguate multi-week periods.
#' When asking for two-week periods, four week-periods, etc, for a given
#' value of x, the choice is ambiguous. For example, when wanting the two-week
#' period for "2022-07-04", should the period cover the 2 weeks commencing
#' "2022-07-03" or the two weeks commencing "2022-06-26"? All multi-week periods
#' will be determined relative to the first day in the week which contains
#' the \code{anchor.date}. Note that this function uses lubridate, where the
#' default week start day is Sunday.
#' @param long.name Logical; if \code{TRUE} the output string is more verbose:
#' months will be their full names, quarters will be written as \code{"Quarter"},
#' and \code{"week commencing"} will be added when code{'week"} is \code{"week"}.
#' @param ... Additional arguments passed to lubridate
#' @importFrom lubridate floor_date make_difftime
#' @export
Period <- function(x, by, anchor.date = as.Date("1970-01-01"), long.name = FALSE, ...)
{
if (is.null(by))
stop("You should use the 'by' argument to specify which periods you ",
"wish to create. For example, by = 'week' for weekly periods.")
if (by == "year")
return(format(floor_date(x, by), "%Y"))
if (by == "month" || by == "quarter") {
if (long.name)
return(format(floor_date(x, by), "%B %Y"))
return(format(floor_date(x, by), "%Y-%m"))
}
if (by == "week") {
week.prefix <- if (long.name) "Week commencing " else ""
return(paste0(week.prefix, format(floor_date(x, by, ...), "%Y-%m-%d")))
}
if (by == "nice.quarter") {
y <- floor_date(x, unit = "quarter")
quarter.prefix <- if(long.name) "Quarter " else "Q"
return(paste0(quarter.prefix, ceiling(month(y)/3), " ", year(y)))
}
multi.week <- endsWith(by, "-week")
if (multi.week) {
if (is.null(anchor.date))
stop("You must specify anchor.date when wanting ", by, " periods.")
n.week <- sub("-week", "", by)
if (!grepl("^\\d+$", n.week))
stop("Invalid number of weeks specified. n-week periods should start with a number, for example: '2-week'")
n.week <- as.numeric(n.week)
dd <- make_difftime(week = n.week)
# Find the difference, in weeks, between x and the anchor date.
week.diff <- as.numeric(anchor.date - x) / (n.week * 7)
# Round it up
week.diff <- ceiling(week.diff)
# Subtract the difference multiplied by the n.week interval
new.date <- floor_date(anchor.date - week.diff * dd, unit = "week", ...)
multi.week.prefix <- if (long.name) paste0(n.week, " weeks commencing ") else ""
return(paste0(multi.week.prefix, format(new.date, "%Y-%m-%d")))
}
format(floor_date(x, by),"%Y-%m-%d")
}
#' \code{Periods}
#'
#' @description Quickly creates period objects.
#' @param x A numeric value of the number of units to be contained in the period. With the exception of seconds(), x must be an integer.
#' @param by The period used in the conversion (e.g., "week", "year").
#' @importFrom lubridate floor_date seconds minutes hours days weeks years
#' @export
Periods <- function(x = 1, by)
{
switch(by,
second = seconds(x),
minute = minutes(x),
hour = hours(x),
day = days(x),
week = weeks(x),
month = months(x),
quarter = months(x * 3),
year = years(x))
}
#' \code{DaysPerPeriod}
#'
#' @description The average number of dates in a period. E.g., 7 for a day, 365.25 for a year.
#' @param by The period used in the conversion (e.g., "week", "year").
#' @examples
#' DaysPerPeriod("month")
#' @export
DaysPerPeriod <- function(by)
{
switch(by, year = 365.25, quarter = 365.25 / 4, month = 365.25 / 12, week = 7, day = 1)
}
#' @title FormatPeriod
#' @description Displays a period in days, hours, minutes and seconds.
#' @param period A period object. Alternatively a numeric corresponding to a
#' number of seconds.
#' @return A string displaying the period:
#' e.g. "1 Day, 2 Hours, 3 Minutes and 4 Seconds"
#' @examples
#' FormatPeriod(1000)
#' @export
FormatPeriod <- function(period)
{
period.seconds <- as.numeric(period)
if (period.seconds <= 0)
result <- "0 Seconds"
else if (period.seconds < 1)
result <- "Less than 1 Second"
else
{
remaining.seconds <- round(period.seconds)
days <- floor(remaining.seconds / 86400)
remaining.seconds <- remaining.seconds - days * 86400
hours <- floor(remaining.seconds / 3600)
remaining.seconds <- remaining.seconds - hours * 3600
minutes <- floor(remaining.seconds / 60)
seconds <- remaining.seconds - minutes * 60
updateOutput <- function(n.units, unit.name, current.output)
{
if (n.units > 0)
{
n.entries <- current.output$n.entries
formatted.period <- current.output$formatted.period
if (n.entries == 1)
formatted.period <- paste0(" and ", formatted.period)
else if (n.entries > 1)
formatted.period <- paste0(", ", formatted.period)
if (n.units == 1)
formatted.period <- paste0("1 ", unit.name, formatted.period)
else
formatted.period <- paste0(n.units, " ", unit.name, "s",
formatted.period)
n.entries <- n.entries + 1
list(formatted.period = formatted.period, n.entries = n.entries)
}
else
current.output
}
current.output <- list(formatted.period = "", n.entries = 0)
current.output <- updateOutput(seconds, "Second", current.output)
current.output <- updateOutput(minutes, "Minute", current.output)
current.output <- updateOutput(hours, "Hour", current.output)
current.output <- updateOutput(days, "Day", current.output)
result <- current.output$formatted.period
}
result
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.