SCM Repository
[latticeextra] / pkg / R / scale.components.R |
View of /pkg/R/scale.components.R
Parent Directory
|
Revision Log
Revision 181 -
(download)
(annotate)
Fri Nov 25 05:23:44 2011 UTC (11 years, 2 months ago) by deepayan
File size: 6305 byte(s)
Fri Nov 25 05:23:44 2011 UTC (11 years, 2 months ago) by deepayan
File size: 6305 byte(s)
traditional graphics style log-scale annotation
## adapted from the Lattice book by Deepayan Sarkar xscale.components.logpower <- function(lim, ...) { ans <- xscale.components.default(lim, ...) ans$bottom$labels$labels <- parse(text = ans$bottom$labels$labels) ans } yscale.components.logpower <- function(lim, ...) { ans <- yscale.components.default(lim, ...) ans$left$labels$labels <- parse(text = ans$left$labels$labels) ans } xscale.components.fractions <- function(lim, logsc = FALSE, ...) { ans <- xscale.components.default(lim, logsc = logsc, ...) ## get 'at' in data coordinates if (identical(logsc, TRUE)) logsc <- 10 if (identical(logsc, "e")) logsc <- exp(1) at <- ans$bottom$labels$at if (!identical(logsc, FALSE)) at <- logsc ^ at ans$bottom$labels$labels <- MASS::fractions(at) ans } yscale.components.fractions <- function(lim, logsc = FALSE, ...) { ans <- yscale.components.default(lim, logsc = logsc, ...) ## get 'at' in data coordinates if (identical(logsc, TRUE)) logsc <- 10 if (identical(logsc, "e")) logsc <- exp(1) at <- ans$left$labels$at if (!identical(logsc, FALSE)) at <- logsc ^ at ans$left$labels$labels <- MASS::fractions(at) ans } ## compute nice log-ticks. This is a version from the Lattice book ## that is not very sophisticated. logTicksOld <- function (lim, loc = c(1, 5)) { ii <- floor(log10(range(lim))) + c(-1, 2) main <- 10^(ii[1]:ii[2]) r <- as.numeric(outer(loc, main, "*")) r[lim[1] <= r & r <= lim[2]] } ## A more sophisticated version that uses the same algorithm used in ## traditional graphics, via axisTicks() - new in R 2.14.0 logTicks <- function (lim, loc = NULL) { if (is.null(loc)) axisTicks(log10(lim), log=TRUE) else logTicksOld(lim, loc) } xscale.components.log <- function(lim, logsc = FALSE, at = NULL, loc = NULL, ...) { ans <- xscale.components.default(lim = lim, logsc = logsc, at = at, ...) if (is.null(at)) return(ans) if (identical(logsc, FALSE)) return(ans) logbase <- logsc if (identical(logbase, TRUE)) logbase <- 10 if (identical(logbase, "e")) logbase <- exp(1) tick.at <- logTicks(logbase^lim, loc = loc) ans$bottom$ticks$at <- log(tick.at, logbase) ans$bottom$labels$at <- log(tick.at, logbase) ans$bottom$labels$labels <- as.character(tick.at) ans } yscale.components.log <- function(lim, logsc = FALSE, at = NULL, loc = NULL, ...) { ans <- yscale.components.default(lim = lim, logsc = logsc, at = at, ...) if (is.null(at)) return(ans) if (identical(logsc, FALSE)) return(ans) logbase <- logsc if (identical(logbase, TRUE)) logbase <- 10 if (identical(logbase, "e")) logbase <- exp(1) tick.at <- logTicks(logbase^lim, loc = loc) ans$left$ticks$at <- log(tick.at, logbase) ans$left$labels$at <- log(tick.at, logbase) ans$left$labels$labels <- as.character(tick.at) ans } xscale.components.log10.3 <- function(lim, logsc = FALSE, at = NULL, ...) { xscale.components.log(lim, logsc = logsc, at = at, loc = c(1, 3)) } yscale.components.log10.3 <- function(lim, logsc = FALSE, at = NULL, ...) { yscale.components.log(lim, logsc = logsc, at = at, loc = c(1, 3)) } # major + minor ticks for powers of 10 xscale.components.log10ticks <- function(lim, logsc = FALSE, at = NULL, ...) { ans <- xscale.components.default(lim = lim, logsc = logsc, at = at, ...) if (is.null(at)) return(ans) if (identical(logsc, FALSE)) return(ans) logbase <- logsc if (identical(logbase, TRUE)) logbase <- 10 if (identical(logbase, "e")) logbase <- exp(1) tick.at <- logTicks(logbase^lim, loc = 1:9) tick.at.major <- logTicks(logbase^lim, loc = 1) major <- tick.at %in% tick.at.major ans$bottom$ticks$at <- log(tick.at, logbase) ans$bottom$ticks$tck <- ifelse(major, 1, 0.5) ans$bottom$labels$at <- log(tick.at, logbase) ans$bottom$labels$labels <- as.character(tick.at) ans$bottom$labels$labels[!major] <- "" ans$bottom$labels$check.overlap <- FALSE ans } yscale.components.log10ticks <- function(lim, logsc = FALSE, at = NULL, ...) { ans <- yscale.components.default(lim = lim, logsc = logsc, at = at, ...) if (is.null(at)) return(ans) if (identical(logsc, FALSE)) return(ans) logbase <- logsc if (identical(logbase, TRUE)) logbase <- 10 if (identical(logbase, "e")) logbase <- exp(1) tick.at <- logTicks(logbase^lim, loc = 1:9) tick.at.major <- logTicks(logbase^lim, loc = 1) major <- tick.at %in% tick.at.major ans$left$ticks$at <- log(tick.at, logbase) ans$left$ticks$tck <- ifelse(major, 1, 0.5) ans$left$labels$at <- log(tick.at, logbase) ans$left$labels$labels <- as.character(tick.at) ans$left$labels$labels[!major] <- "" ans$left$labels$check.overlap <- FALSE ans } ## major + minor ticks (e.g. for date/time axes): xscale.components.subticks <- function(lim, ..., n = 5, n2 = n * 5, min.n2 = n + 5) { ans <- xscale.components.default(lim = lim, ..., n = n) ans2 <- xscale.components.default(lim = lim, ..., n = n2, min.n = min.n2) ticks <- ans$bottom$ticks$at ticks2 <- ans2$bottom$ticks$at ticks2 <- ticks2[!(ticks2 %in% ticks)] ans$bottom$ticks$at <- c(ticks, ticks2) ans$bottom$ticks$tck <- c(rep(1, length(ticks)), rep(0.5, length(ticks2))) ans$bottom$labels$at <- ans$bottom$ticks$at ans$bottom$labels$labels <- c(ans$bottom$labels$labels, rep(" ", length(ticks2))) ans$bottom$labels$check.overlap <- FALSE ans } yscale.components.subticks <- function(lim, ..., n = 5, n2 = n * 5, min.n2 = n + 5) { ans <- yscale.components.default(lim = lim, ..., n = n) ans2 <- yscale.components.default(lim = lim, ..., n = n2, min.n = min.n2) ticks <- ans$left$ticks$at ticks2 <- ans2$left$ticks$at ticks2 <- ticks2[!(ticks2 %in% ticks)] ans$left$ticks$at <- c(ticks, ticks2) ans$left$ticks$tck <- c(rep(1, length(ticks)), rep(0.5, length(ticks2))) ans$left$labels$at <- ans$left$ticks$at ans$left$labels$labels <- c(ans$left$labels$labels, rep(" ", length(ticks2))) ans$left$labels$check.overlap <- FALSE ans }
root@r-forge.r-project.org | ViewVC Help |
Powered by ViewVC 1.0.0 |