[R] Plotting with dates on X axis
Jack Lewis
jl7001 at axe.humboldt.edu
Thu Apr 6 04:53:33 CEST 2000
I wrote a function I call axis.time() that I use to plot time axes when the x
variable is a "dates" or "chron" object created by the "chron" library from
http://lib.stat.cmu.edu/R/CRAN/src/contrib/PACKAGES.html#info
A typical sequence of commands for plotting would be:
plot(chron.object, y, axes=F, xlab="", ...)
axis.time(chron.object)
axis(2)
box()
The labelling scheme varies depending on how many days are being plotted. The
function gives nice results for time periods ranging from a couple of days to
several months. It is not elegant; please improve upon it if you like. (Let me know
if you do). Also, I suppose a method could be added for the plot() function that
would automatically call axis.time() if a chron or dates object were passed as the
x variable.
In addition to axis.time(), I have included a replacement function for
format.times(). It is needed to display times correctly (the chron version
truncates the floating point representation, thus displaying, for example, 05:29:59
instead of 05:30:00).
"axis.time" <-
function(chron.obj, side = 1, m = 1, labels = T, hours = labels)
{
# Creates a date/time axis for up to 2 years
#
# Arguments:
# chron.obj = dates or chron object to be plotted on x axis
# side = 1 (bottom axis) or 3 (top axis)
# m = relative tic length
# labels = logical, indicates whether to label the axis
# hours = logical, indicates whether to label the hours
#
edate <- trunc(max(chron.obj))
sdate <- trunc(min(chron.obj))
orig <- origin(sdate)
xlim <- par()$usr[1:2]
ndays <- edate - sdate #
# Daily tic marks
ticlocs <- seq((sdate - 1), (edate + 1))
if(ndays > 10 && ndays <= 21)
ticlen <- -0.04 * m
else ticlen <- -0.02 * m
axis(side, at = ticlocs, labels = F, tck = ticlen)
if (ndays <=10) axis(side,at=ticlocs,labels=F, tck= 0.015*m) #
# Daily tic mark labels
if(labels & ndays < 60) {
ticlocs <- seq((sdate - 1), edate)
lablocs <- ticlocs + 0.5
line <- 1
if(ndays <= 10) {
mm <- format(ticlocs, " m ")
dd <- format(ticlocs, " d ")
yy <- substring(format(ticlocs, "yy"), 3, 4)
ticlabels <- paste(mm, dd, yy, sep = "/")
textsize <- 0.75
}
else if(ndays <= 21) {
mm <- format(ticlocs, " m ")
dd <- format(ticlocs, " d ")
ticlabels <- paste(mm, dd, sep = "/")
textsize <- 0.6
}
else if(ndays <= 31) {
ticlabels <- as.character(days(ticlocs))
textsize <- 0.6
line <- 0.5
}
else {
ticlabels <- as.character(days(ticlocs))
textsize <- 0.45
line <- 0.2
}
in.range <- (lablocs >= xlim[1]) & (lablocs <= xlim[2])
if(sum(in.range) > 0)
mtext(ticlabels[in.range], side = 1, at = ticlocs[in.range] + 0.5, line =
line, cex = textsize)
}
if(ndays > 21) {
# Monthly tics and labels
syear <- as.character(years(sdate))
eyear <- as.character(years(edate))
span <- as.numeric(eyear) - as.numeric(syear)
if(span > 1)
stop("end year - start year > 1")
if(span == 1) {
seq1 <- seq(months(sdate), 12)
seq2 <- seq(1, months(edate))
mseq <- c(seq1, seq2)
yseq <- c(rep(syear, length(seq1)), rep(eyear, length(seq2)))
}
else {
mseq <- seq(months(sdate), months(edate))
yseq <- c(rep(syear, length(mseq)))
}
yseq _ substring(yseq,3,4)
ticlocs <- dates(paste(zfill(mseq, 2), 1, yseq, sep = "/"), origin = orig)
lablocs <- dates(paste(zfill(mseq, 2), 16, yseq, sep = "/"), origin = orig)
text <- months(lablocs)
axis(side, at = ticlocs, label = F, tck = -0.04 * m)
if(ndays > 31)
line <- 1
else line <- 1.5
in.range <- (lablocs >= xlim[1]) & (lablocs <= xlim[2])
if(labels && sum(in.range) > 0)
mtext(as.character(text[in.range]), side = 1, at = lablocs[in.range], line =
line)
}
if(ndays <= 31) {
# 6-hour tics and labels
ticlocs <- seq(as.numeric(sdate - 1), as.numeric(edate + 1), by = 1/4)
if(ndays <= 4 && hours)
ticlabels <- round(24 * ticlocs %% 1)
else ticlabels <- F
if(ndays <= 21)
ticlen <- -0.02 * m
else ticlen <- -0.01 * m
axis(side, at = ticlocs, labels = ticlabels, tck = ticlen, mgp = c(3, 0.1, 0),
cex.axis=0.5)
}
if(ndays <= 10) {
# Hourly tics
ticlocs <- seq(as.numeric(sdate - 1), as.numeric(edate + 1), by = 1/24)
axis(side, at = ticlocs, labels = F, tck = -0.01 * m)
}
}
"format.times" <-
function(x, format. = "h:m:s", simplify = F, ...)
{
# This function was copied from chron library and modified to
# round seconds instead of truncating, and incrementing minutes
# and hours if necessary when ss==60
if(!length(x)) return("")
if(all(is.na(x)))
return(rep("NA", length = length(x)))
if(!is.numeric(x))
stop(paste(deparse(substitute(x)), "must be numeric"))
att <- attributes(x)
if(inherits(x, "times")) {
if(missing(format.))
format. <- switch(mode(att$format),
character = ,
list = rev(att$format)[[1]],
name = ,
"function" = att$format,
NULL = format.,
stop("invalid output times format"))
class(x) <- NULL
}
if(!is.character(format.)) {
# format may be a function or name
FUN <- switch(mode(format.),
"function" = format.,
name = eval(format.),
stop(paste("unrecognized time format", deparse(substitute(format.)))))
return(FUN(unclass(x), ...))
}
else format. <- rev(format.)[1]
nas <- is.na(x)
days <- abs(trunc(x))
att$class <- att$format <- att$origin <- NULL
if(any(days[!nas] > 0)) {
attributes(x) <- att
return(format(x))
}
sec <- 24 * 3600 * abs(x)
hh <- sec %/% 3600
mm <- (sec - hh * 3600) %/% 60
ss <- round(sec - hh * 3600 - 60 * mm)
mm[ss == 60] <- mm[ss == 60] + 1
ss[ss == 60] <- 0
hh[mm == 60] <- hh[mm == 60] + 1
mm[mm == 60] <- 0
out <- list(h = substring(paste("0", hh, sep = ""), nchar(paste(hh))), m =
substring(paste(
"0", mm, sep = ""), nchar(paste(mm))), s = substring(paste("0", ss, sep = ""),
nchar(
paste(ss))))
style <- parse.format(format.)
o <- style$periods
if(!simplify)
out <- paste(out[[o[1]]], out[[o[2]]], out[[o[3]]], sep = style$sep)
else {
if(simplify == 1) {
# no secs
o <- o[o != "s"]
out <- paste(out[[o[1]]], out[[o[2]]], sep = style$sep)
}
else out <- out$h
}
if(any(x[!nas] < 0))
out <- paste(ifelse(x < 0, "-", ""), out, sep = "")
out[nas] <- NA
out[x == Inf] <- "Inf"
out[x == - Inf] <- "-Inf"
attributes(out) <- att
out
}
Good luck, Jack Lewis
--
Jack Lewis Redwood Sciences Laboratory
707-825-2929 voice Pacific Southwest Research Station
707-825-2901 fax USDA Forest Service
jl7001 at axe.humboldt.edu http://www.rsl.psw.fs.fed.us
jlewis01 at fs.fed.us (alternate)
--------------------------------------------
Thought must be divided against itself before it can come to any
knowledge of itself. (Aldous Huxley)
--------------------------------------------------------------------
"M. Lang & S. Railsback" wrote:
> Is there a trick to drawing a graph with date-formatted values as one of
> the axes? Here is my code:
>
> library(date)
> MortDate <-as.date(MortalityDate)
>
> ...
>
> plot(MortDate,AqPred,type="l", xlim=range(MortDate), ylim=c(0,MaxY))
>
> The plot actually has the formatted date values as the X axis labels,
> but they are overwritten by unformatted (integer) Julian dates.
>
> Then the vector of Julian dates appears underneath the plot as:
>
> c(14611, 14611, ...
>
> and so on for two lines.
>
> Using the plot parameter xaxt = "t" does not help.
> I'm using R1000 for Windows.
>
> Thanks
>
> Steve Railsback
> --
> LRA at NORTHCOAST.COM
> Lang, Railsback & Assoc.
> 250 California Ave., Arcata CA 95521
> 707-822-0453; Fax 822-1868
> -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
> r-help mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
> Send "info", "help", or "[un]subscribe"
> (in the "body", not the subject !) To: r-help-request at stat.math.ethz.ch
> _._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-help mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !) To: r-help-request at stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
More information about the R-help
mailing list