#' @title Label date axis
#' @description Labels date axes at sensible monthly intervals in the
#' time domain of years to decades.
#' @return List with locations of month and year labels and ticks, each a Date vector.
#' @author Berry Boessenkool, \email{berry-b@@gmx.de}, Feb + Dec 2015, Oct 2017
#' @seealso \code{\link{monthLabs}} for the numbercrunching itself,
#' \code{\link{timeAxis}} for shorter or longer time frames,
#' \code{\link{axis.Date}} with defaults that are less nice.
#' @keywords chron aplot dplot
#' @importFrom graphics axis par
#' @importFrom utils str tail
#' @export
#' @examples
#'
#' set.seed(007) # for reproducibility
#' timePlot <- function(nydays, start="2013-08-25", ...)
#' plot(as.Date(start)+sort(c(0,sample(1:nydays, 50))),
#' cumsum(rnorm(51)), type="l", xaxt="n", ann=FALSE, las=1, ...)
#'
#' timePlot(1100)
#' monthAxis()
#' monthAxis(1, nmonths=6, col.axis="red") # 2013 not labeled anymore
#' monthAxis(side=3, nym_half=2) # if axis > 2 years, label only partially
#'
#' timePlot(2e3)
#' monthAxis() # long time series (>nym_none) only have years labeled
#' monthAxis(side=3, font=2, grid=TRUE)
#' # vertical lines in graph - now add lines/points
#'
#' timePlot(900)
#' monthAxis(side=3, mtcl=0) # no tick lines between months
#' monthAxis(ycex=1.4, ytcl=2, lwd.ticks=2)
#' monthAxis(yline=1, col.axis=4, col=4)
#' monthAxis(mcex=1, col.axis="red", yformat=" ") # no years labeled
#' timePlot(900)
#' monthAxis(nmonths=1) # year labeled for short period as well
#'
#' timePlot(800)
#' monthAxis()
#' monthAxis(mgp=c(2,1,0)) # the same. element 2 is relevant here
#' monthAxis(mgp=c(3,0,0)) # requires change in mline andy yline placement
#'
#' timePlot(400)
#' ma <- monthAxis(lwd=3, yl=list(col.axis=3), mlabels=letters[1:12], mcex=1)
#' abline(v=ma$mtics, col=8) # use output from monthAxis for other functions
#'
#' timePlot(80)
#' monthAxis(mlabels=month.abb, mcex=1) # short time series give a warning
#'
#' timePlot(80, "2013-11-14")
#' monthAxis(mlabels=month.abb, mcex=1, nmonths=0, quiet=TRUE)
#'
#' # Time axis instead of date axis:
#' plot(as.POSIXct(Sys.time()+c(0,2)*360*24*3600), 1:2, xaxt="n")
#' monthAxis(nmonths=2)
#'
#' timePlot(800, "2015-01-01")
#' monthAxis()
#' timePlot(900, "2015-01-01", xaxs="i")
#' monthAxis()
#' timePlot(300, "2015-01-01", xaxs="i")
#' monthAxis() # if less than a full year is covered, the year label is centered
#'
#' @param side Which \code{\link{axis}} is to be labeled? DEFAULT: 1
#' @param grid Add horizontal/vertical lines to graph? DEFAULT: FALSE
#' @param time Logical indicating whether the axis is \code{\link{POSIXct}},
#' not \code{\link{Date}}. DEFAULT: NA, meaning axis value >1e5
#' @param origin Origin for\code{\link{as.Date}} and \code{\link{as.POSIXct}}.
#' DEFAULT: "1970-01-01"
#' @param mlabels Labels for the months. DEFAULT: J,F,M,A,M,J,J,A,S,O,N,D
#' @param yformat Format of year labels, see details in \code{\link{strptime}}.
#' Use \code{yformat=" "} (with space) to suppress year labeling.
#' DEFAULT: "\%Y"
#' @param nmonths Minimum number of months required before a year at the
#' axis boundary is labeled. DEFAULT: 3
#' @param nym_half Number of years on axis above which only every second month
#' is labeled. DEFAULT: 3.5
#' @param nym_none Number of years on axis above which the months are
#' not labeled. DEFAULT: 5
#' @param mcex \code{cex.axis} (letter size) for month labels. DEFAULT: 0.7
#' @param ycex \code{cex.axis} (letter size) for year labels. DEFAULT: 1
#' @param mtcl Month tick length (negative text line height units).
#' 0 to suppress ticks. DEFAULT: par("tcl") = -0.5
#' @param ytcl Year tick length (negative text line height units).
#' 0 to suppress ticks. DEFAULT: par("tcl")-1.7 = -2.2
#' @param mline Line of month labels. DEFAULT: -1
#' @param yline Line of year labels. DEFAULT: 0.2
#' @param las LabelAxisStyle for orientation of labels. DEFAULT: 1 (upright)
#' @param lrange Label range (two \code{\link{Date}} values).
#' DEFAULT: NA = internally computed from \code{\link{par}("usr")}
#' @param trunc Vector with two values: Number of days/seconds to truncate
#' at the left and right end of lrange. DEFAULT: NA
#' @param mgp MarGin Placement. Suggested not to change this, since
#' _tcl and _line defaults are chosen for the DEFAULT: c(3,1,0)
#' @param mt,ml,yt,yl Lists with further arguments passed to \code{\link{axis}},
#' like \code{lwd, col.ticks, lwd.ticks, hadj, lty}, separately
#' for month ticks, month labels, year ticks, year labels.
#' DEFAULT: NULL
#' @param quiet Suppress warning about short time axis? DEFAULT: FALSE
#' @param \dots Arguments passed to \code{\link{axis}} for all 4 elements.
#'
monthAxis <- function(
side = 1,
grid = FALSE,
time = NA,
origin = "1970-01-01",
mlabels = substr(month.abb,1,1),
yformat = "%Y",
nmonths = 3,
nym_half = 3.5,
nym_none = 5,
mcex = 0.7,
ycex = 1,
mtcl = par("tcl"),
ytcl = par("tcl")-1.7,
mline = -1,
yline = 0.2,
las = 1,
lrange = NA,
trunc = NA,
mgp = c(3,1,0),
mt=NULL, ml=NULL, yt=NULL, yl=NULL,
quiet=FALSE,
...
)
{
# Input checks:
op <- par(mgp=mgp)
on.exit(par(op), add=TRUE)
if(yformat=="") warning("yformat='' gives unexpected labeling. Did you mean yformat=' '?")
if(nmonths>=12) nmonths <- 11
if(length(mlabels)!=12)
{
warning("length(mlabels) should be 12, not ",length(mlabels), ". Is now recycled.")
mlabels <- rep(mlabels, length.out=12)
}
names(mlabels) <- round0(1:12, pre=2)
# get Date range from current graph or from input:
if(anyNA(lrange))
{
lrange <- par("usr")[if(side%%2) 1:2 else 3:4]
}
else
{
# lrange class check:
if(!inherits(lrange, c("Date","POSIXlt"))) stop("class(lrange) must be
'Date' or 'POSIXlt', not '", toString(class(lrange)), "'.")
lrange <- range(lrange, na.rm=TRUE)
}
trunc <- rep(trunc, length.out=2) # recycle trunc
if(!is.na(trunc[1])) lrange[1] <- lrange[1] + trunc[1]
if(!is.na(trunc[2])) lrange[2] <- lrange[2] - trunc[2]
# time default (TRUE if values at axis are very large):
if(is.na(time)) time <- lrange[1]>1e5
if(time) lrange <- as.POSIXct(lrange, origin=origin)
lrange <- as.Date(lrange, origin=origin)
dif <- as.numeric(difftime(lrange[2], lrange[1], units="days"))/365.24
if(dif>nym_half) mlabels[1:6*2] <- ""
if(dif>nym_none) mlabels <- ""
if(dif<1 & !quiet) warning("The axis is shorter than a year (", dif*365.24,
" days). timeAxis might yield better labels than monthAxis.")
# calculate tick and label locations as date values:
getYear <- function(x) as.numeric(format(x, "%Y"))
# months
mtics <- monthLabs(getYear(lrange[1])-1, getYear(lrange[2])+1, npm=1)
mlabs <- mtics+14
mtics <- mtics[between(mtics, lrange-30, lrange+30, quiet=TRUE)]
mlabs <- mlabs[between(mlabs, lrange, quiet=TRUE)]
# years
ytics <- monthLabs(getYear(lrange[1]), getYear(lrange[2]), npy=1)
ylabs <- ytics[between(ytics, lrange, lrange-365.24, quiet=TRUE)]+183-1
ytics <- ytics[between(ytics, lrange, quiet=TRUE)]
# add year labels for partially displayed years:
jday <- as.numeric(format(lrange,"%j"))
addlow <- between(jday[1],2,365-nmonths*30.5, quiet=TRUE)
addupp <- between(jday[2], nmonths*30.5, 365, quiet=TRUE)
if(addlow & addupp & length(ytics)<1) {ylabs <- mean(lrange)} else
{
if(addlow) ylabs <- c(mean(c(lrange[1], ytics[1]), na.rm=T), ylabs)
if(addupp) ylabs <- c(ylabs, mean(c(lrange[2], tail(ytics,1)), na.rm=T))
}
ylabs <- ylabs[between(ylabs, lrange, quiet=TRUE)]
# Convert to POSIXct if needed:
if(time)
{
mtics <- as.POSIXct(mtics)
mlabs <- as.POSIXct(mlabs)
ytics <- as.POSIXct(ytics)
ylabs <- as.POSIXct(ylabs)
}
# prepare inputs with defaults:
mtd <- list(side=side, at=mtics, labels=FALSE, tcl=mtcl, ...)
ytd <- list(side=side, at=ytics, labels=FALSE, tcl=ytcl, ...)
mld <- list(side=side, at=mlabs, labels=mlabels[format(mlabs,"%m")],
las=las, line=mline, cex.axis=mcex, tick=FALSE, ...)
yld <- list(side=side, at=ylabs, labels=format(ylabs,yformat),
las=las, line=yline, cex.axis=ycex, tick=FALSE, ...)
# actually label axis:
do.call(axis, owa(mtd, mt))
do.call(axis, owa(ytd, yt))
do.call(axis, owa(mld, ml))
do.call(axis, owa(yld, yl))
if(grid)
{
if(side%%2){abline(v=mtics, col="grey90"); abline(v=ytics, col="grey70")} else
{abline(h=mtics, col="grey90"); abline(h=ytics, col="grey70")}
box()
}
# output:
return(invisible(list(mlabs=mlabs, ylabs=ylabs, mtics=mtics, ytics=ytics)))
} # End of function
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.