R/dateStem.R

In jbrzusto/sensorgnome-R-package: Tools for the sensorgnome project.

#' Get the common portion of a range of dates.
#'
#' For a sequence of POSIXct or POSIXt date/times, return a string summarizing
#' the constant portion of the range; ie. that shared among all dates.
#' The main purpose of this is to provide additional information for xyplot()s
#' that don't have enough detail on the time axis to let you know what period
#' of time you're looking at.  For this reason, one extra component is included
#' when dates cross a unit boundary, but span less than a unit; e.g. if the
#' date range goes overnight, but isn't a full day in size.
#' 
#' @param dates vector of POSIXct or POSIXt date/times
#' 
#' @param formats character vector; formatting strings compatible with
#'     \code{strftime} and \code{lubridate}; the n-th element is the
#'     format string to use if the first date/time component which
#'     varies among \code{dates} is \code{n}.  The last element of
#'     this vector is used if the range of dates agrees among more
#'     leading components than formats.  Defaults to: c("", "%Y",
#'     "%Y %b", "%Y %b %d", "%Y %b %d, %I %p", "%Y %b %d, %I%M %p",
#'     "%Y %b %d, %I:%M:%S %p") which might only make sense for
#'     locales that use a 12-hour clock.
#'
#' @return character scalar; this is earliest element of \code{dates}, formatted with the \code{n}-th element
#' of \code{formats}, where $code{n} is the index of the first date/time component that varies among \code{dates};
#' i.e.:
#' \enumerate{
#' \item \code{n=1} if the year varies among \code{dates}
#' \item \code{n=2} if the year is constant but the month varies
#' \item \code{n=3} if the year and month are constant but the day varies
#' \item etc.
#' }
#' If \code{length(formats) < n}, the last element of \code{formats} is used.
#'
#' This function is intended for use in labelling time axes in plots generated by \code{lattice::xyplot()}
#' when the latter does not display enough information to fully determine the displayed date/time.
#' 
#' @author John Brzustowski \email{jbrzusto@@REMOVE_THIS_PART_fastmail.fm}
#'
#' @examples
#' library(lubridate)
#' dateStem(ymd("2013-05-01", "2014-06-15")) ## returns ""
#' dateStem(ymd("2014-05-01", "2014-06-15")) ## returns "2014"
#' dateStem(ymd("2014-05-01", "2014-05-10")) ## returns "2014 May"
#' dateStem(ymd_hms("2014-05-01 03:20:17", "2014-05-01 21:09:32")) ## returns "2014 May 1"
#' dateStem(ymd_hms("2014-05-01 03:20:17", "2014-05-01 03:09:32")) ## returns "2014 May 1, 03 AM"
#' dateStem(ymd_hms("2014-05-01 03:20:17", "2014-05-01 03:20:32")) ## returns "2014 May 1, 03:20 AM"
#' dateStem(ymd_hms("2014-05-01 03:20:17", "2014-05-01 03:20:17")) ## returns "2014 May 1, 03:20:17 AM"

dateStem = function(dates, formats=c("", "%Y", "%Y %b", "%Y %b %d", "%Y %b %d, %I %p", "%Y %b %d, %I:%M %p", "%Y %b %d, %I:%M:%S %p")) {
    ## beginning and ending dates
    b = min(dates)
    e = max(dates)

    parts = as.POSIXlt(c(b, e))

    ## difference in date components
    diffs = lapply(unclass(parts)[c("year", "mon", "mday", "hour", "min", "sec")], diff)
    n = which(diffs != 0)[1]

    if (is.na(n) || n > length(formats)) {
        n = length(formats)
    } else if (n < length(formats) & diffs[n] == 1) {
        n = n + 1
    }

    ## work around annoying behaviour of format(DATE, FMT), when FMT is ""
    return(if (nchar(formats[n]) > 0) format(b, formats[n]) else "")
}