1#  File src/library/graphics/R/axis.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 1995-2019 The R Core Team
5#
6#  This program is free software; you can redistribute it and/or modify
7#  it under the terms of the GNU General Public License as published by
8#  the Free Software Foundation; either version 2 of the License, or
9#  (at your option) any later version.
10#
11#  This program is distributed in the hope that it will be useful,
12#  but WITHOUT ANY WARRANTY; without even the implied warranty of
13#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14#  GNU General Public License for more details.
15#
16#  A copy of the GNU General Public License is available at
17#  https://www.R-project.org/Licenses/
18
19axis <- function(side, at = NULL, labels = TRUE, tick = TRUE, line = NA,
20                 pos = NA, outer = FALSE, font = NA,
21                 lty = "solid", lwd = 1, lwd.ticks = lwd,
22                 col = NULL, col.ticks = NULL,
23                 hadj = NA, padj = NA, gap.axis = NA, ...)
24{
25    ## we need to do this as the C code processes 'col' before '...'
26    if(is.null(col) && !missing(...) && !is.null(fg <- list(...)$fg))
27        ## help(par) 'fg' says this should work
28        col <- fg
29    ## watch out: some people do things like
30    ## axis(1, at = my.at <- 10^(1L:5), labels = formatC(my.at, format="fg"))
31    ## which depends on the order of evaluation of the args.
32    invisible(.External.graphics(C_axis, side, at, as.graphicsAnnot(labels),
33          tick, line, pos, outer, font, lty, lwd, lwd.ticks,
34          col, col.ticks, hadj, padj, gap.axis, ...))
35}
36
37
38Axis <- function(x = NULL, at = NULL, ..., side, labels = NULL)
39{
40    if (!is.null(x)) UseMethod("Axis", x)
41    else if (!is.null(at)) UseMethod("Axis", at)
42    else axis(side = side, at = at, labels = labels, ...)
43}
44
45Axis.default <- function(x = NULL, at = NULL, ..., side, labels = NULL)
46    axis(side = side, at = at, labels = labels, ...)
47
48Axis.table <- function(x, at, ..., side = 1, labels)
49{
50     if (length(dim(x)) == 1) {
51         nx <- dimnames(x)[[1]]
52         ow <- options(warn = -1)
53         is.num <- !any(is.na(xx <- as.numeric(nx)))
54         options(ow)
55         x0 <- if (is.num) xx else seq.int(x)
56         if(missing(at)) at <- x0
57         if(missing(labels)) labels <- nx
58         axis(side, at = at, labels = labels, ...)
59     }
60     else stop("only for 1-D table")
61}
62
63
64
65## Note that axTicks() can be used without any graphics device
66## when (axp, usr, log, nintLog) are specified..
67axTicks <- function(side, axp = NULL, usr = NULL, log = NULL, nintLog = NULL)
68{
69    ## Compute tickmark "at" values which axis(side) would use by default;
70    ## using par("Xaxp") , par("usr") & par("Xlog") where X = x|y
71    ## an R version of internal CreateAtVector()
72    if(!(side <- as.integer(side)) %in% 1L:4L)
73        stop("'side' must be in {1:4}")
74    is.x <- side %% 2 == 1
75    XY <- function(ch) paste0(if(is.x) "x" else "y", ch)
76    if(is.null(axp)) axp <- par(XY("axp"))
77    else if(!is.numeric(axp) || length(axp) != 3) stop("invalid 'axp'")
78    if(is.null(log)) log <- par(XY("log"))
79    else if(!is.logical(log) || anyNA(log)) stop("invalid 'log'")
80    if(log && axp[3L] > 0) { ## special log-scale axp[]
81        if(!any((iC <- as.integer(axp[3L])) == 1L:3L))
82            stop("invalid positive 'axp[3]'")
83        if(is.null(usr)) usr <- par("usr")[if(is.x) 1:2 else 3:4]
84        else if(!is.numeric(usr) || length(usr) != 2) stop("invalid 'usr'")
85        if(is.null(nintLog)) nintLog <- par("lab")[2L - is.x]
86        if(is.finite(nintLog)) { # based on internal CreateAtVector() in ../../../main/plot.c
87            axisTicks(usr, log=log, axp=axp, nint=nintLog)
88        } else { ## nintLog = Inf <--> "cheap" back compatible
89	    if(needSort <- is.unsorted(usr)) { ## need sorting for reverse axes
90		usr <- usr[2:1]; axp <- axp[2:1]
91	    } else axp <- axp[1:2]
92	    ii <- round(log10(axp))
93	    x10 <- 10^((ii[1L] - (iC >= 2L)):ii[2L])
94	    r <- switch(iC, ## axp[3]
95			x10,			     ## 1
96			c(outer(c(1,  5), x10))[-1L],## 2
97			c(outer(c(1,2,5), x10))[-1L])## 3
98	    if(needSort) # revert
99		r <- rev(r)
100            r[usr[1L] <= log10(r) & log10(r) <= usr[2L]]
101        }
102    } else { # linear
103	n <- as.integer(abs(axp[3L]) + 0.25)
104	r <- seq.int(axp[1L], axp[2L], length.out = n + 1L)
105	## zapsmall(r), but using same computations as C-based axisTicks():
106	n. <- max(1L, n)
107	r[abs(r) < abs(axp[2L] - axp[1L])/(100*n.)] <- 0
108	r
109    }
110}
111