### Copyright 2001-2003 Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library for R.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
###
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE. See the GNU General Public License for more
### details.
###
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA
calculateAxisComponents <- function(x, ..., abbreviate = NULL, minlength = 4)
## This aims to be a general function which given a general
## 'range' x and optional at, generates the locations of tick
## marks and corresponding labels.
## x is guaranteed to be given (possibly NA). Possible cases
## correspond to factors (character/expression), shingle (see
## below), "POSIXt", "date" and usual numeric. The last case will
## be default, and will be changed later if necessary.
## Theres no need to handle shingles specially. Shingles can also
## be thought of as numeric, and thus the default is more
## appropriate for functions like xyplot. In functions like
## bwplot, things will be adjusted elsewhere when one of the
## variables is a shingle.
## Note that at and labels will never be TRUE (it's set up that
## way), so it's enough to check if they are is.logical(), which
## means they are not explicitly specified.
## The variables about log scales are required for cases where at
## is explicitly specified. In such cases, at will be
## log(at,base=logbase), but labels would correspond to at.
{
if (all(is.na(x)))
return(list(at = numeric(0),
labels = numeric(0),
check.overlap = TRUE,
num.limit = c(0,1)))
## Get ticks and labels depending on x (generic defined below)
ans <- formattedTicksAndLabels(x, ...)
## remove labels outside limits
rng <- range(ans$num.limit)
ok <- ans$at >= rng[1] & ans$at <= rng[2]
ans$at <- ans$at[ok]
ans$labels <- ans$labels[ok]
## abbreviate labels if requested
if (is.logical(abbreviate) && abbreviate)
ans$labels <- abbreviate(ans$labels, minlength)
ans
}
formattedTicksAndLabels <- function(x, ...)
UseMethod("formattedTicksAndLabels")
formattedTicksAndLabels.default <-
function (x, at = FALSE, labels = FALSE, logsc = FALSE,
abbreviate = NULL, minlength = 4, format.posixt, ...)
## meant for when x is numeric
{
## handle log scale (most other methods ignore logsc)
if (is.logical(logsc) && logsc) logsc <- 10
have.log <- !is.logical(logsc) || logsc
logbase <-
if (is.numeric(logsc)) logsc
else exp(1)
logpaste <-
if (have.log) paste(as.character(logsc), "^", sep = "")
else ""
## will check for overlap only when neither at nor labels is specified
check.overlap <-
if (is.logical(at) && is.logical(labels)) TRUE
else FALSE
if (is.logical(at)) ## at not explicitly specified
{
at <- pretty(x[is.finite(x)], ...)
}
else if (have.log) ## and at specified
{
if (is.logical(labels)) labels <- as.character(at)
at <- log(at, base = logbase)
}
list(at = at, labels = if (is.logical(labels))
paste(logpaste, format(at, trim = TRUE), sep = "") else labels,
check.overlap = check.overlap,
num.limit = if (length(x) == 2) x else range(x))
}
formattedTicksAndLabels.date <-
function (x, at = FALSE, labels = FALSE, logsc = FALSE,
abbreviate = NULL, minlength = 4, format.posixt, ...)
{
## handle log scales (not very meaningful, though)
if (is.logical(logsc) && logsc) logsc <- 10
have.log <- !is.logical(logsc) || logsc
logbase <-
if (is.numeric(logsc)) logsc
else exp(1)
## will check for overlap only when neither at nor labels is specified
check.overlap <-
if (is.logical(at) && is.logical(labels)) TRUE
else FALSE
if (is.logical(at)) ## at not explicitly specified
{
at <- as.integer(pretty(x[is.finite(x)], ...))
class(at) <- "date"
datelabels <- as.character(at)
}
else if (have.log) ## and at specified
{
if (is.logical(labels)) labels <- as.character(at)
at <- log(at, base = logbase)
}
list(at = at,
labels = if (is.logical(labels)) datelabels else labels,
check.overlap = check.overlap,
num.limit = if (length(x) == 2) as.numeric(x) else as.numeric(range(x)))
}
## The next two are actually identical
formattedTicksAndLabels.character <-
function (x, at = FALSE, labels = FALSE, logsc = FALSE,
abbreviate = NULL, minlength = 4, format.posixt, ...)
{
ans <- list(at = if (is.logical(at)) seq(along = x) else at,
labels = if (is.logical(labels)) x else labels,
check.overlap = FALSE)
ans$num.limit <- c(0, length(ans$at) + 1)
ans
}
formattedTicksAndLabels.expression <-
function (x, at = FALSE, labels = FALSE, logsc = FALSE,
abbreviate = NULL, minlength = 4, format.posixt, ...)
{
ans <- list(at = if (is.logical(at)) seq(along = x) else at,
labels = if (is.logical(labels)) x else labels,
check.overlap = FALSE)
ans$num.limit <- c(0, length(ans$at) + 1)
ans
}
formattedTicksAndLabels.POSIXct <-
function (x, at = FALSE, labels = FALSE, logsc = FALSE,
abbreviate = NULL, minlength = 4,
format.posixt = NULL, ...)
{
## modified from axis.POSIXct.
num.lim <- if (length(x) == 2) as.numeric(x) else as.numeric(range(x))
mat <- is.logical(at)
mlab <- is.logical(labels)
if (!mat)
x <- as.POSIXct(at)
else x <- as.POSIXct(x)
range <- as.numeric(range(x))
d <- range[2] - range[1]
z <- c(range, x[is.finite(x)])
if (d < 1.1 * 60) {
sc <- 1
if (is.null(format.posixt))
format.posixt <- "%S"
}
else if (d < 1.1 * 60 * 60) {
sc <- 60
if (is.null(format.posixt))
format.posixt <- "%M:%S"
}
else if (d < 1.1 * 60 * 60 * 24) {
sc <- 60 * 24
if (is.null(format.posixt))
format.posixt <- "%H:%M"
}
else if (d < 2 * 60 * 60 * 24) {
sc <- 60 * 24
if (is.null(format.posixt))
format.posixt <- "%a %H:%M"
}
else if (d < 7 * 60 * 60 * 24) {
sc <- 60 * 60 * 24
if (is.null(format.posixt))
format.posixt <- "%a"
}
else {
sc <- 60 * 60 * 24
}
if (d < 60 * 60 * 24 * 50) {
zz <- pretty(z/sc, ...)
z <- zz * sc
class(z) <- c("POSIXt", "POSIXct")
if (is.null(format.posixt))
format.posixt <- "%b %d"
}
else if (d < 1.1 * 60 * 60 * 24 * 365) {
class(z) <- c("POSIXt", "POSIXct")
zz <- as.POSIXlt(z)
zz$mday <- 1
zz$isdst <- zz$hour <- zz$min <- zz$sec <- 0
zz$mon <- pretty(zz$mon, ...)
m <- length(zz$mon)
m <- rep(zz$year[1], m)
zz$year <- c(m, m + 1)
z <- as.POSIXct(zz)
if (is.null(format.posixt))
format.posixt <- "%b"
}
else {
class(z) <- c("POSIXt", "POSIXct")
zz <- as.POSIXlt(z)
zz$mday <- 1
zz$isdst <- zz$mon <- zz$hour <- zz$min <- zz$sec <- 0
zz$year <- pretty(zz$year, ...)
z <- as.POSIXct(zz)
if (is.null(format.posixt))
format.posixt <- "%Y"
}
if (!mat)
z <- x[is.finite(x)]
z <- z[z >= range[1] & z <= range[2]]
labels <- format(z, format = format.posixt)
list(at = as.numeric(z), labels = labels,
check.overlap = FALSE,
num.limit = num.lim)
}