Re: [R] Plotting with dates on X axis

About this list Date view Thread view Subject view Author view Other groups

Subject: Re: [R] Plotting with dates on X axis
From: Jack Lewis (jl7001@axe.humboldt.edu)
Date: Thu 06 Apr 2000 - 12:53:33 EST


Message-ID: <38EBFC2D.7D2A4E16@axe.humboldt.edu>

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@axe.humboldt.edu              http://www.rsl.psw.fs.fed.us
jlewis01@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@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@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@stat.math.ethz.ch _._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._


About this list Date view Thread view Subject view Author view Other groups

This archive was generated by hypermail 2b25 : Mon 17 Jul 2000 - 12:33:14 EST