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